Loop through all cells in worksheet a, copy and consolidate to b minus blanks

[RobGEOD]

I have data in rows 1-50 and columns A:AN. For each cell in columns 2,4,6,etc. has data I need to copy that cell and the one next to it to a consolidated worksheet in groups of 50. Below is a small example of what I'm trying to do:

Data
[TABLE="width: 500"]
<tbody>[TR]
[TD]1
[/TD]
[TD]aaaaa
[/TD]
[TD]6
[/TD]
[TD]bbbb
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD][/TD]
[TD]7
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]aaaaa
[/TD]
[TD]8
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]aaaaa
[/TD]
[TD]9
[/TD]
[TD]bbbb
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD][/TD]
[TD]10
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

Desired output
[TABLE="width: 500"]
<tbody>[TR]
[TD]1
[/TD]
[TD]aaaaa
[/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]aaaaa
[/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]aaaaa
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]bbbb
[/TD]
[/TR]
[TR]
[TD]9
[/TD]
[TD]bbbb
[/TD]
[/TR]
</tbody>[/TABLE]

 

[Rick Rothstein]

Give this macro a try...

[table="width: 500"]
[tr]
	[td]Sub AllToActive()
  Dim R As Long, LastCol As Long, Col As Long
  Application.ScreenUpdating = False
  With Sheets("All")
    LastCol = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    For Col = 1 To LastCol Step 2
      Intersect(.Columns(Col).Resize(, 2), .Rows("1:50")).Copy Sheets("NewActive").Cells(Rows.Count, "A").End(xlUp).Offset(1)
    Next
  End With
  With Sheets("NewActive")
    On Error GoTo NoBlanks
    .Columns("B").SpecialCells(xlBlanks).EntireRow.Delete
    For R = 51 To .Cells(Rows.Count, "A").End(xlUp).Row Step 50
      .Cells(R, "A").Resize(50, 2).Cut .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
    Next
  End With
NoBlanks:
  Application.ScreenUpdating = True
End Sub[/td]
[/tr]
[/table]

 

[RobGEOD]

Rick Rothstein, you are the MAN! Works perfectly. Thank you, thank you, thank you!

Give this macro a try...

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub AllToActive()
  Dim R As Long, LastCol As Long, Col As Long
  Application.ScreenUpdating = False
  With Sheets("All")
    LastCol = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    For Col = 1 To LastCol Step 2
      Intersect(.Columns(Col).Resize(, 2), .Rows("1:50")).Copy Sheets("NewActive").Cells(Rows.Count, "A").End(xlUp).Offset(1)
    Next
  End With
  With Sheets("NewActive")
    On Error GoTo NoBlanks
    .Columns("B").SpecialCells(xlBlanks).EntireRow.Delete
    For R = 51 To .Cells(Rows.Count, "A").End(xlUp).Row Step 50
      .Cells(R, "A").Resize(50, 2).Cut .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
    Next
  End With
NoBlanks:
  Application.ScreenUpdating = True
End Sub[/TD]
[/TR]
</tbody>[/TABLE]

 

[hiker95]

Done. Thanks. https://drive.google.com/file/d/1b5_4McthTLjbDpnhDrKGdohaz0t4RmGN/view?usp=sharing

RobGEOD,

I will only open workbooks, with the xlsx file extension on https://dropbox.com per my reply #15.

Maybe someone else on MrExcel will be able to assist you.