I have a spreadsheet that survey's equipment condition for equipment condition for multiple places, which is designated by ID (see Data Input example). For each row I need the equipment under the columns header "E1" and "E1C" copy/pasted into another worksheet ("Data Output") with the ID number associtated with that row and then "E2" & "E2C" copy pasted into next blank row with the same ID. Keep looping through the columns and skip the nonblank cells in each row. After going through all the columns in a row it should go to the next row until there is a row with no data (blank row).
Data Input example (smaller example of what the table looks like)
<colgroup><col><col><col span="10"></colgroup><tbody>
</tbody>
The "Data Output Example" image can help explain what I mean.
<colgroup><col><col><col></colgroup><tbody>
</tbody>
The code i have so far does what the intended output should do, but it is hard coded instead of looping through the rows/columns and automatically skipping blank cells.
Option Explicit
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim source As Worksheet, target As Worksheet
Dim r As Range, rB As Range
'range is B:L. B8:L8 empty so skipped
'next is B9:L9. skip J9:L9 becuase empty
Sheets("Source").Range("B9:C9,A9").Copy
Sheets("ET target").Range("A2").PasteSpecial xlValues
Sheets("Source").Range("D9:E9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("D9:E9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("F9:G9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("H9:I9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
'Skip B10:L10 empty. Next is B11:L11. Skip F11:L11 becuase empty
Sheets("Source").Range("B11:C11,A11").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("D11:E11,A11").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
'Skip B12:L14 becuase empty. Next is B15:L15. skip H15:L15 becuase empty
Sheets("Source").Range("B15:C15,A15").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("D15:E15,A15").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("F15:G15,A15").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
'Repeat for upto 200 rows.
Application.ScreenUpdating = True
End Sub
Sorry if there is duplicate threads somewhere. I have looked through quite a few posts and did not find anything that i could tailor to fit. Thanks for your help!
Data Input example (smaller example of what the table looks like)
ID | E1 | E1C | E2 | E2C | E3 | E3C | E4 | E4C | E5 | E5C | ET5C |
10 | |||||||||||
11 | N600D | 9 | N600D | 9 | N600D | 9 | N2000D+ | 9 | |||
12 | |||||||||||
13 | N2000D+ | 2 | N2000D | 5 | |||||||
14 | |||||||||||
15 | |||||||||||
16 | |||||||||||
17 | N2000D+ | 9 | N2000D+ | 0 | N2000D+ | 7 | |||||
18 | |||||||||||
19 | |||||||||||
20 | |||||||||||
195 | N600D | 9 | N2000D+ | 8 |
<colgroup><col><col><col span="10"></colgroup><tbody>
</tbody>
The "Data Output Example" image can help explain what I mean.
ID | Model | Condition |
11 | N600D | 9 |
11 | N600D | 9 |
11 | N600D | 9 |
11 | N600D | 9 |
13 | N2000D+ | 2 |
13 | N2000D | 5 |
17 | N2000D+ | 9 |
17 | N2000D+ | 0 |
17 | N2000D+ | 7 |
195 | N600D | 9 |
195 | N2000D+ | 8 |
<colgroup><col><col><col></colgroup><tbody>
</tbody>
The code i have so far does what the intended output should do, but it is hard coded instead of looping through the rows/columns and automatically skipping blank cells.
Option Explicit
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim source As Worksheet, target As Worksheet
Dim r As Range, rB As Range
'range is B:L. B8:L8 empty so skipped
'next is B9:L9. skip J9:L9 becuase empty
Sheets("Source").Range("B9:C9,A9").Copy
Sheets("ET target").Range("A2").PasteSpecial xlValues
Sheets("Source").Range("D9:E9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("D9:E9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("F9:G9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("H9:I9,A9").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
'Skip B10:L10 empty. Next is B11:L11. Skip F11:L11 becuase empty
Sheets("Source").Range("B11:C11,A11").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("D11:E11,A11").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
'Skip B12:L14 becuase empty. Next is B15:L15. skip H15:L15 becuase empty
Sheets("Source").Range("B15:C15,A15").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("D15:E15,A15").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Sheets("Source").Range("F15:G15,A15").Copy
Sheets("ET target").Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
'Repeat for upto 200 rows.
Application.ScreenUpdating = True
End Sub
Sorry if there is duplicate threads somewhere. I have looked through quite a few posts and did not find anything that i could tailor to fit. Thanks for your help!