Loop through a range of cells and skip blank cells.

testrad

New Member
Joined
May 20, 2015
Messages
6
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)

IDE1E1CE2E2CE3E3CE4E4CE5E5CET5C
10
11N600D9N600D9N600D9N2000D+9
12
13N2000D+2N2000D 5
14
15
16
17N2000D+9N2000D+0N2000D+7
18
19
20
………………………………
195N600D9N2000D+8

<colgroup><col><col><col span="10"></colgroup><tbody>
</tbody>

The "Data Output Example" image can help explain what I mean.

IDModelCondition
11N600D9
11N600D9
11N600D9
11N600D9
13N2000D+2
13N2000D5
17N2000D+9
17N2000D+0
17N2000D+7
………
195N600D9
195N2000D+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!
 
What do you mean by "can the ranges be on the sheet8"? Are you asking if the code needs to search for the entire title of the headers? If so, the headers are unique enough to only need the first 2 letters. I.E. If the code is designed to search the range by looking for the headers with "ET" instead of "ET1", "ET1-Mobility", etc., and then paste those cell ranges into the other sheet; then that would work.
 
Upvote 0

Excel Facts

Get help while writing formula
Click the italics "fx" icon to the left of the formula bar to open the Functions Arguments dialog. Help is displayed for each argument.
What do you mean by "can the ranges be on the sheet8"? Are you asking if the code needs to search for the entire title of the headers? If so, the headers are unique enough to only need the first 2 letters. I.E. If the code is designed to search the range by looking for the headers with "ET" instead of "ET1", "ET1-Mobility", etc., and then paste those cell ranges into the other sheet; then that would work.


Try this

The macro will create the sheets "ET", "UT", etc., always with two characters.
You can add more columns as shown in the example.

Code:
Sub Loop_range()
  Dim sh1 As Worksheet, sh2 As Worksheet, ar As Range, f As Range, ant As String
  Dim j As Long, ini As Long, fin As Long, lr As Long, lr1 As Long
  
  Application.ScreenUpdating = False
  Set sh1 = Sheets("Source")
  ini = Columns("AQ").Column
  For j = ini To sh1.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
    If ant <> Left(sh1.Cells(1, j), 2) Then
      Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(sh1.Cells(1, j), 2)
    End If
    lr1 = sh1.Cells(Rows.Count, j).End(xlUp).Row
    If lr1 > 1 Then
      For Each ar In sh1.Range(sh1.Cells(2, j), sh1.Cells(lr1, j)).SpecialCells(xlCellTypeConstants).Areas
        lr = Range("A" & Rows.Count).End(xlUp)(2).Row
        '[COLOR=#008000]Here you can put the columns you need[/COLOR]
        Range("[COLOR=#ff0000]A[/COLOR]" & lr).Value = sh1.Cells(ar.Row, "[COLOR=#ff0000]A[/COLOR]")    'ID
        Range("[COLOR=#ff0000]B[/COLOR]" & lr).Value = sh1.Cells(ar.Row, "[COLOR=#ff0000]B[/COLOR]")    '[COLOR=#008000]example 1[/COLOR]
        Range("[COLOR=#ff0000]C[/COLOR]" & lr).Value = sh1.Cells(ar.Row, "[COLOR=#ff0000]C[/COLOR]")    '[COLOR=#008000]example 2[/COLOR]
        Range("[COLOR=#ff0000]D[/COLOR]" & lr).Value = sh1.Cells(ar.Row, j)      'Model
        Range("[COLOR=#ff0000]E[/COLOR]" & lr).Value = sh1.Cells(ar.Row, j + 1)  'condition
      Next
    End If
    ant = Left(sh1.Cells(1, j), 2)
  Next
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,938
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top