Loop through a range of cells and skip blank cells.

T

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)

[TABLE="width: 791"]
<colgroup><col><col><col span="10"></colgroup><tbody>[TR]
[TD]ID[/TD]
[TD]E1[/TD]
[TD]E1C[/TD]
[TD]E2[/TD]
[TD]E2C[/TD]
[TD]E3[/TD]
[TD]E3C[/TD]
[TD]E4[/TD]
[TD]E4C[/TD]
[TD]E5[/TD]
[TD]E5C[/TD]
[TD]ET5C[/TD]
[/TR]
[TR]
[TD]10[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[TD]N2000D+[/TD]
[TD]9[/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]12[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]N2000D+[/TD]
[TD]2[/TD]
[TD]N2000D [/TD]
[TD]5[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]14[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]15[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]16[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]N2000D+[/TD]
[TD]9[/TD]
[TD]N2000D+[/TD]
[TD]0[/TD]
[TD]N2000D+[/TD]
[TD]7[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]18[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]19[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]20[/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD] [/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[/TR]
[TR]
[TD]195[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[TD]N2000D+[/TD]
[TD]8[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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

[TABLE="width: 211"]
<colgroup><col><col><col></colgroup><tbody>[TR]
[TD]ID[/TD]
[TD]Model[/TD]
[TD]Condition[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]11[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]N2000D+[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]13[/TD]
[TD]N2000D[/TD]
[TD]5[/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]N2000D+[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]N2000D+[/TD]
[TD]0[/TD]
[/TR]
[TR]
[TD]17[/TD]
[TD]N2000D+[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD]…[/TD]
[TD]…[/TD]
[TD]…[/TD]
[/TR]
[TR]
[TD]195[/TD]
[TD]N600D[/TD]
[TD]9[/TD]
[/TR]
[TR]
[TD]195[/TD]
[TD]N2000D+[/TD]
[TD]8

[/TD]
[/TR]
</tbody>[/TABLE]

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!
 
Sort by date Sort by votes
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

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes
testrad said:
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.
Click to expand...


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
You must log in or register to reply here.

Similar threads

A
  • Solved
Copy/Paste Adjacent Cell
Replies
6
Views
384
mumps
mumps
B
  • Question Question
VBA Code to Send Mail to skip blank cells
Replies
1
Views
332
Micron
M
H
  • Solved
Macro to speedy up process when copying Data
Replies
3
Views
110
Logit
Logit
C
  • Solved
Copy data from multiple sheets into a master sheet - VBA button stuck
Replies
3
Views
372
NdNoviceHlp
NdNoviceHlp
N
  • Solved
VBA - Increment range and loop until blank Cell
Replies
3
Views
330
dreid1011
dreid1011

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

Share this page

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