VBA to copy from a range based on a condition

LOrndoff · Aug 15, 2014

I am new to this, so please bear with me. Here is a small sample of my data.

CODES	1	6	7	8	9	10A	10B
AC1	0.00	0.00	0.00	5.00	0.00	0.00	1.00
AC2	0.00	0.00	0.00	0.00	0.00	0.00	0.00
AC3	0.00	0.00	0.00	0.00	3.00	0.00	0.00
AC4	0.00	0.00	0.00	0.00	0.00	0.00	1.00

CODES	#DEFECTS	SHOP

I am trying to write the code to search through range B2:AI31 and if the cell does not contain a 0, then copy the code in column A (AC1, AC2, etc.) to the codes column; copy the corresponding # of the defects in the row, and then copy the number of the shop from row A1:AI1. If someone could give me a push in the right direction I sure would appreciate it. Thanks!

hiker95 · Aug 15, 2014

LOrndoff,

Welcome to the MrExcel forum.

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?

So that we can get it right on the first go, can we have another text display/screenshot of what the results should look like?

LOrndoff · Aug 15, 2014

Sorry, I forgot that part. I am using Windows 7 Professional and Excel 2010.

DEFECTS
CODES	1	6	7	8	9	10A	10B	10B-2	10B-3	10B-4	10B-5	11	13A	13B	14A	14B	15	16	L3-1	L3-2	L3-3	L3-4	L3-5	L3-6	TOTALS	CODES	#DEFECTS	SHOP
AC1	0.00	0.00	0.00	5.00	0.00	0.00	1.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	6.00
AC2	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00
AC3	0.00	0.00	0.00	0.00	3.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	1.00	2.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	6.00
AC4	0.00	0.00	0.00	0.00	0.00	0.00	1.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	1.00
AC5	0.00	5.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	5.00
AF1	0.00	0.00	0.00	3.00	2.00	0.00	0.00	0.00	0.00	0.00	0.00	1.00	1.00	0.00	2.00	2.00	0.00	0.00	0.00	0.00	1.00	0.00	0.00	0.00	12.00
AW1	0.00	0.00	16.00	107.00	273.00	1460.00	0.00	42.00	146.00	0.00	0.00	1006.00	0.00	0.00	57.00	188.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	3327.00
B1	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00
C1	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00
CP1	0.00	1.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	1.00
D1	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	1.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	1.00
E1	0.00	1.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	1.00
E2	0.00	6.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	6.00
E3	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00
E4	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00
E5	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00
L1	0.00	0.00	0.00	10.00	22.00	0.00	32.00	0.00	0.00	0.00	0.00	95.00	0.00	0.00	124.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	0.00	251.00

I hope this helps.

JoeMo · Aug 15, 2014

This places the output starting in column AK.

Code:

Sub LOrndoff()
Dim lR As Long, R As Range, vA As Variant, vO() As Variant, Ct As Long
lR = Range("A" & Rows.Count).End(xlUp).Row
Set R = Range("A1:AI" & lR)
vA = R.Value
ReDim vO(1 To Columns("A:AI").Count * UBound(vA, 1), 1 To 3)
Range("AK1:AM1").Value = Array("CODE", "#DEFECTS", "SHOP")
For i = 2 To UBound(vA, 1)
    For j = 2 To UBound(vA, 2)
        If vA(i, j) <> 0 Then
            Ct = Ct + 1
            vO(Ct, 1) = vA(i, 1)
            vO(Ct, 2) = vA(i, j)
            vO(Ct, 3) = vA(1, j)
        End If
    Next j
Next i
If Ct > 0 Then
    Range("AK2:AM" & Ct + 1).Value = vO
End If
End Sub

hiker95 · Aug 15, 2014

LOrndoff,

After looking at your data, I think I understand.

Sample raw data:

Excel 2007

A

B

C

D

E

F

G

H

I

1

CODES

1

6

7

8

9

10A

10B

2

AC1

0

5

0

1

3

AC2

0

4

AC3

0

3

0

5

AC4

0

1

6

Sheet1

After the macro (using two arrays in memory) in a new worksheet Results:

Excel 2007

A

B

C

1

CODES

#DEFECTS

SHOP

2

AC1

5

8

3

AC1

1

10B

4

AC3

3

9

5

AC4

1

10B

6

Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Code:

Sub ReorgData()
' hiker95, 08/15/2014, ME799240
Dim w1 As Worksheet, wr As Worksheet
Dim a As Variant, o As Variant
Dim i As Long, j As Long
Dim lr As Long, lc As Long, n As Long, c As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")
With w1
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = Application.CountIf(.Range(.Cells(2, 2), .Cells(lr, lc)), ">0")
  ReDim o(1 To n + 1, 1 To 3)
End With
j = 1
o(j, 1) = "CODES": o(j, 2) = "#DEFECTS": o(j, 3) = "SHOP"
For i = 2 To lr
  For c = 2 To lc
    If a(i, c) <> 0 Then
      j = j + 1
      o(j, 1) = a(i, 1)
      o(j, 2) = a(i, c)
      o(j, 3) = a(1, c)
    End If
  Next c
Next i
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
With wr
  .UsedRange.Clear
  .Cells(1, 1).Resize(n + 1, 3).Value = o
  .Columns(1).Resize(, 3).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

hiker95 · Aug 15, 2014

LOrndoff,

Sample raw data:

Excel 2007

A

B

C

D

E

F

G

H

I

1

CODES

1

6

7

8

9

10A

10B

2

AC1

0.00

5.00

0.00

1.00

3

AC2

0.00

4

AC3

0.00

3.00

0.00

5

AC4

0.00

1.00

6

DEFECTS

After the new macro (using two arrays in memory) in a new worksheet Results:

Excel 2007

A

B

C

1

CODES

#DEFECTS

SHOP

2

AC1

5.00

8

3

AC1

1.00

10B

4

AC3

3.00

9

5

AC4

1.00

10B

6

Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Code:

Sub ReorgData_V2()
' hiker95, 08/15/2014, ME799240
Dim wd As Worksheet, wr As Worksheet
Dim a As Variant, o As Variant
Dim i As Long, j As Long
Dim lr As Long, lc As Long, n As Long, c As Long
Application.ScreenUpdating = False
Set wd = Sheets("DEFECTS")
With wd
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  lc = .Cells(1, Columns.Count).End(xlToLeft).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = Application.CountIf(.Range(.Cells(2, 2), .Cells(lr, lc)), ">0")
  ReDim o(1 To n + 1, 1 To 3)
End With
j = 1
o(j, 1) = "CODES": o(j, 2) = "#DEFECTS": o(j, 3) = "SHOP"
For i = 2 To lr
  For c = 2 To lc
    If a(i, c) <> 0 Then
      j = j + 1
      o(j, 1) = a(i, 1)
      o(j, 2) = a(i, c)
      o(j, 3) = a(1, c)
    End If
  Next c
Next i
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=wd).Name = "Results"
Set wr = Sheets("Results")
With wr
  .UsedRange.Clear
  .Cells(1, 1).Resize(n + 1, 3).Value = o
  .Range(.Cells(2, 2), .Cells(n + 1, 2)).NumberFormat = "0.00"
  .Columns(1).Resize(, 3).AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData_V2 macro.

LOrndoff · Aug 15, 2014

Thanks you both very much for your quick reply. Unfortunately, I won't be able to test it till I go back to work on Monday. I will be sure and let you know how things work out. Thanks again!

hiker95 · Aug 15, 2014

LOrndoff,

Thanks you both very much for your quick reply.

You are very welcome. Glad we could help.

We will be here when you reply again - see you then.

DocAElstein · Aug 17, 2014

Hi,

……and just for completeness, a Simple Sort Program from a beginner without the Array and other clever Stuff!

……This code:

'Option Explicit 'forces you to define your variable Types. - saves copmuter space and error show up easier Sub SimpleSortOfSort() Dim InputTableLastColumn As Byte, InputTableLastRow As Byte, ShopColumn As Byte, DefectCodeRow As Byte 'Define variable for last Column and Last Row and a Count variable for Columnns and a count for Rows. (Byte limits size to 255) Let InputTableLastColumn = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column 'Go to last Column in first Row, then go back left until you reach the last cell with data in in Row 1, then give that column Number Let InputTableLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'Go to last Row in first Column, go back up until you reach the last cell with data in in column1 1, then give that Row Number Dim FinalTableRowNumber As Byte 'define the variable used for the number of your outpu Rows in a loop which works out the contents of each row.**(Byte limits you to 255 Rows) Let FinalTableRowNumber = 1 ' Give it a first value for first row ' 'Now go througth looking for wot you want in the final table..... ** For ShopColumn = 2 To InputTableLastColumn - 1**'Go through every Shop Column... **** For DefectCodeRow = 2 To InputTableLastRow '...then go through every table Row defect number ****** If Worksheets("Sheet1").Cells(DefectCodeRow, ShopColumn).Value <> 0 Then ' Then.... If you have a defect..... ****** Let FinalTableRowNumber = FinalTableRowNumber + 1 'Start new Row in final table ****** Worksheets("Sheet1").Cells(FinalTableRowNumber, InputTableLastColumn + 2).Value = Worksheets("Sheet1").Cells(DefectCodeRow, 1).Value 'Put Defect Code in colum you wanted to ****** Worksheets("Sheet1").Cells(FinalTableRowNumber, InputTableLastColumn + 3).Value = Worksheets("Sheet1").Cells(DefectCodeRow, ShopColumn).Value 'Put number of Defects in column you wanted to! ****** Worksheets("Sheet1").Cells(FinalTableRowNumber, InputTableLastColumn + 4).Value = Worksheets("Sheet1").Cells(1, ShopColumn).Value 'Pur the shop number in column you waned to! ****** Else ' If**defect =0, then... ****** 'Do nothing!! ****** End If **** Next DefectCodeRow ' Try next row ** Next ShopColumn ' After all rows are tried then go and start again for next shop column ' ' Now put the headings where you wanted! Worksheets("sheet1").Cells(1, InputTableLastColumn + 2).Value = "Defect Code" Worksheets("sheet1").Cells(1, InputTableLastColumn + 3).Value = "Number of Defects" Worksheets("sheet1").Cells(1, InputTableLastColumn + 4).Value = "Shop Number" End Sub 'SimpleSortOfSort()

….and the Code again simplified without ‘Green comment graffiti etc:

Code:

Sub SimplifiedSimpleSortOfSort()FinalTableRowNumber = 1
   For ShopColumn = 2 To Cells(1, Columns.Count).End(xlToLeft).Column - 1
     For DefectCodeRow = 2 To Cells(Rows.Count, 1).End(xlUp).Row
       If Cells(DefectCodeRow, ShopColumn).Value <> 0 Then
       Let FinalTableRowNumber = FinalTableRowNumber + 1
       Cells(FinalTableRowNumber, Cells(1, Columns.Count).End(xlToLeft).Column + 2).Value = Cells(DefectCodeRow, 1).Value
       Cells(FinalTableRowNumber, Cells(1, Columns.Count).End(xlToLeft).Column + 3).Value = Cells(DefectCodeRow, ShopColumn).Value
       Cells(FinalTableRowNumber, Cells(1, Columns.Count).End(xlToLeft).Column + 4).Value = Cells(1, ShopColumn).Value
       End If
     Next DefectCodeRow
   Next ShopColumn
Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 2).Value = "Defect Code"
Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 3).Value = "Number of Defects"
Cells(1, Cells(1, Columns.Count).End(xlToLeft).Column + 4).Value = "Shop Number"
End Sub

…..when applied to your raw data, gives this:

Book1

Z

AA

AB

AC

AD

AE

AF

1

TOTALS

Defect Code

Number of Defects

Shop Number

2

6

AC5

5

6

3

0

CP1

1

6

4

6

E1

1

6

5

1

E2

6

5

AW1

16

7

12

AC1

5

8

3327

AF1

3

8

9

0

AW1

107

8

10

0

L1

10

8

11

1

AC3

3

9

12

1

AF1

2

9

13

1

AW1

273

9

14

6

L1

22

9

15

0

AW1

1460

10A

16

0

AC1

1

10B

17

0

AC4

1

10B

18

251

L1

32

10B

19

AW1

42

10B-2

20

AW1

146

10B-3

21

AF1

1

11

22

AW1

1006

11

23

L1

95

11

24

AF1

1

13A

25

D1

1

13B

26

AF1

2

14A

27

AW1

57

14A

28

L1

124

14A

29

AC3

1

14B

30

AF1

2

14B

31

AW1

188

14B

32

AC3

2

15

33

AF1

1

L3-3

34

Sheet1

Or when applied to this sample data……

Book1

A

B

C

D

E

F

G

H

I

J

1

Defect Code

Shop 1

Shop 6

Shop 7

Shop 8

Shop 9

Shop 10A

Shop 10B

Totals

2

AC1

0

4

0

5

0

1

3

AC2

0

4

AC3

0

3

0

5

AC4

0

1

6

7

Sheet1

..gives this:

Book1

I

J

K

L

M

N

1

Totals

Defect Code

Number of Defects

Shop Number

2

AC1

4

Shop 6

3

AC1

5

Shop 8

4

AC3

3

Shop 9

5

AC1

1

Shop 10B

6

AC4

1

Shop 10B

7

8

Sheet1

The full File with your Raw data and the code (in Sheet1 Module) is here.
FileSnack | Easy file sharing

If you need any Basic help in getting started running any of our codes, then get back and one of us will give you some instructions

Alan

P.s. “A Picture paints a thousand Words”. It is most useful if, along with your description of the problem, you also . 1 include a full table (like your raw data one, but perhaps a bit shortened in rows and Columns because of space limitation in the Thread).

. 2 A table showing exactly how the output table should then look (with manually typed in results) once the macro is run.

(. 3 Although the input and output tables can be on the same sheet, it is somewhat more convenient if they are on different sheets, again because of the space limitations in the Thread).

DocAElstein · Aug 17, 2014

The full code again without the ***** stuff which should not be there?!?

'Option Explicit 'forces you to define your variable Types. - saves copmuter space and error show up easier Sub SimpleSortOfSort() Dim InputTableLastColumn As Byte, InputTableLastRow As Byte, ShopColumn As Byte, DefectCodeRow As Byte 'Define variable for last Column and Last Row and a Count variable for Columnns and a count for Rows. (Byte limits size to 255) Let InputTableLastColumn = Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column 'Go to last Column in first Row, then go back left until you reach the last cell with data in in Row 1, then give that column Number Let InputTableLastRow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row 'Go to last Row in first Column, go back up until you reach the last cell with data in in column1 1, then give that Row Number Dim FinalTableRowNumber As Byte 'define the variable used for the number of your outpu Rows in a loop which works out the contents of each row. (Byte limits you to 255 Rows) Let FinalTableRowNumber = 1 ' Give it a first value for first row ' 'Now go througth looking for wot you want in the final table..... For ShopColumn = 2 To InputTableLastColumn - 1 'Go through every Shop Column... For DefectCodeRow = 2 To InputTableLastRow '...then go through every table Row defect number If Worksheets("Sheet1").Cells(DefectCodeRow, ShopColumn).Value <> 0 Then ' Then.... If you have a defect..... Let FinalTableRowNumber = FinalTableRowNumber + 1 'Start new Row in final table Worksheets("Sheet1").Cells(FinalTableRowNumber, InputTableLastColumn + 2).Value = Worksheets("Sheet1").Cells(DefectCodeRow, 1).Value 'Put Defect Code in colum you wanted to Worksheets("Sheet1").Cells(FinalTableRowNumber, InputTableLastColumn + 3).Value = Worksheets("Sheet1").Cells(DefectCodeRow, ShopColumn).Value 'Put number of Defects in column you wanted to! Worksheets("Sheet1").Cells(FinalTableRowNumber, InputTableLastColumn + 4).Value = Worksheets("Sheet1").Cells(1, ShopColumn).Value 'Pur the shop number in column you waned to! Else ' If defect =0, then... 'Do nothing!! End If Next DefectCodeRow ' Try next row Next ShopColumn ' After all rows are tried then go and start again for next shop column ' ' Now put the headings where you wanted! Worksheets("sheet1").Cells(1, InputTableLastColumn + 2).Value = "Defect Code" Worksheets("sheet1").Cells(1, InputTableLastColumn + 3).Value = "Number of Defects" Worksheets("sheet1").Cells(1, InputTableLastColumn + 4).Value = "Shop Number" End Sub 'SimpleSortOfSort()

VBA to copy from a range based on a condition

LOrndoff

New Member

Excel Facts

hiker95

Well-known Member

LOrndoff

New Member

JoeMo

MrExcel MVP

hiker95

Well-known Member

hiker95

Well-known Member

LOrndoff

New Member

hiker95

Well-known Member

DocAElstein

Banned user

DocAElstein

Banned user

Similar threads

Forum statistics

Share this page

VBA to copy from a range based on a condition

New Member

Excel Facts

Well-known Member

New Member

MrExcel MVP

Well-known Member

Well-known Member

New Member

Well-known Member

Banned user

Banned user

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock