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

1	aaaaa	6	bbbb
2		7
3	aaaaa	8
4	aaaaa	9	bbbb
5		10

<tbody>
</tbody>

Desired output

1	aaaaa
3	aaaaa
4	aaaaa
6	bbbb
9	bbbb

<tbody>
</tbody>

 

[JLGWhiz]

By blanks, I am going to assume you mean blank rows as opposed to blank cells within a row.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
sh1.UsedRange.Offset(1).SpecialCells(xlCellTypeConstants).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
End Sub

In case you do have blanks in the rows.

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, lr As Long
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
lr = sh1.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
sh1.Range("A2:A" & lr).SpecialCells(xlCellTypeConstants).EntireRow.Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
End Sub

 

[My Aswer Is This]

Next to it is not a definitive. Do you mean to the left of it or to the right of it,

So you want A and B and C and D

Or B and C and D and E

 

[JLGWhiz]

After closer reading of the OP.

Sub t2()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
    For Each c In sh1.Range("A2:AN50")
        If x = 50 Then
            If c <> "" And c.Offset(, 1).Value <> "" Then
                x = 0
                c.Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(2)
               
            Else: GoTo Skip
            End If
        End If
        If c <> "" And c.Offset(, 1).Value <> "" Then
            c.Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            
            x = x + 1
        End If
Skip:
    Next
End Sub

 

[My Aswer Is This]

Another piece of information:
This post is a duplicate on this same forum here:
https://www.mrexcel.com/forum/excel...orksheet-copy-consolidate-b-minus-blanks.html

 

[RobGEOD]

Thanks for the response. I meant the cell to the left. I was hoping the sample data I posted would help clear it up. I need to loop through 50 rows of cells in even numbered columns so (2, 1), (2, 2)... (2, 50), for each cell in the even columns with data I need to pick up that cell and the cell to its left and consolidate those cells to another worksheet in groups of 50.

 

[RobGEOD]

Another piece of information:
This post is a duplicate on this same forum here:
https://www.mrexcel.com/forum/excel...orksheet-copy-consolidate-b-minus-blanks.html

I didn't see the first one in my queue so I created a second thinking the first didn't exist. I still don't see it.

 

[RobGEOD]

After closer reading of the OP.

Sub t2()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Sheets(1) 'Edit sheet name
Set sh2 = Sheets(2) 'Edit sheet name
    For Each c In sh1.Range("A2:AN50")
        If x = 50 Then
            If c <> "" And c.Offset(, 1).Value <> "" Then
                x = 0
                c.Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(2)
               
            Else: GoTo Skip
            End If
        End If
        If c <> "" And c.Offset(, 1).Value <> "" Then
            c.Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            
            x = x + 1
        End If
Skip:
    Next
End Sub

Thanks for the reply. This didn't work. It went by 50 through all of the cells.

 

[hiker95]

RobGEOD,

If I understand you correctly, then here is a macro solution for you to consider, that is based on your flat text displays, that will adjust to the number of raw data rows, and, columns, and, that uses two arrays in memory, and, should be fast.

I assume that both worksheets, Data, and, Consolidated, already exist.

You can change the worksheet names in the macro.


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.

Sub ConsolidateData()
' hiker95, 11/15/2017, ME1031659
Dim wd As Worksheet, wc As Worksheet
Dim a As Variant, i As Long, c As Long, lr As Long, lc As Long, n As Long
Dim o As Variant, j As Long
Set wd = Sheets("Data")   '<-- you can change the sheet name here
Set wc = Sheets("Consolidated")   '<-- you can change the sheet name here
Application.ScreenUpdating = False
With wd
  lr = .Cells.Find("*", , xlValues, xlWhole, xlByRows, xlPrevious, False).Row
  lc = .Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlPrevious, False).Column
  a = .Range(.Cells(1, 1), .Cells(lr, lc))
  n = lr * (lc / 2)
  ReDim o(1 To n, 1 To 2)
End With
For c = 2 To lc Step 2
  For i = 1 To lr Step 1
    If Not a(i, c) = vbEmpty Then
      j = j + 1: o(j, 1) = a(i, c - 1): o(j, 2) = a(i, c)
    End If
  Next i
Next c
With wc
  .UsedRange.ClearContents
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o
  .UsedRange.Columns.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, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ConsolidateData macro.

 

[hiker95]

RobGEOD,

If my macro in my reply #9 does not work correctly, then, can we see your actual raw data workbook/worksheets?


You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com