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]

 

[RobGEOD]

I have been playing with it today and I have come up with the following code. This code doesn't copy any attributes like color or formatting and I can only figure out how to do the first 2 columns. Thanks for any help.

Option Explicit
Sub activeOnly()
' Pull cells that aren't empty from and consolidate them to active
Dim ws As Worksheet, ws1 As Worksheet
Dim a As Variant, o As Variant
Dim i As Long, ii As Long, n As Long
Application.ScreenUpdating = False
If Not Evaluate("ISREF(Active!A1)") Then Worksheets.Add().Name = "Active"                       'does sheet exist, if not create it
    Set ws1 = Worksheets("Active")
    ws1.Columns("A:AN").Clear                                                                   'clear any data in A through AN
ReDim o(1 To 50, 1 To 40)                                                                       'reallocate space for array variable
Set ws = Worksheets("All")
    a = ws.Range("A1:AN" & ws.Range("A" & Rows.Count).End(xlUp).Row)                            'get total count
    For i = LBound(a) To UBound(a)                                                              'lowest of a to highest of a
      If a(i, 2) <> "" Then
        ii = ii + 1
        o(ii, 1) = a(i, 1): o(ii, 2) = a(i, 2)
      End If
    Next i

With ws1
  .Cells(1, 1).Resize(UBound(o, 1), UBound(o, 2)) = o                                           'resize cells
  .Columns("A:AN").AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

 

[RobGEOD]

Thanks Hiker. This is really close. This is going to go onto a share point like portal that displays the first page. I would like to keep the formatting and start new columns after 50. Any ideas?

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,

In the future when asking for help, and, you already have a macro, it would help us if you would post all of your macro code.

 

[RobGEOD]

Yep. I posted what I came up with today. I'm a beginner so I've been searching for ideas all afternoon.

RobGEOD,

In the future when asking for help, and, you already have a macro, it would help us if you would post all of your macro code.

 

[hiker95]

Thanks Hiker. This is really close. This is going to go onto a share point like portal that displays the first page. I would like to keep the formatting and start new columns after 50. Any ideas?

RobGEOD,

You are welcome.

In order to continue I would have to see your actual raw data workbook/worksheets, with the resulting worksheet manually completed by you for the results that you are looking for.


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

 

[RobGEOD]

Here you go. I put your macro in it. https://drive.google.com/file/d/1JErtIzvsdwxiWvhgtQqU3Ah5QOOUtNah/view?usp=sharing

RobGEOD,

You are welcome.

In order to continue I would have to see your actual raw data workbook/worksheets, with the resulting worksheet manually completed by you for the results that you are looking for.


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

 

[JLGWhiz]

poHere is one more try, using the even number columns.

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
With sh1
    For i = 2 To 50 Step 2
        For j = 2 To 51 'Assumes header row
        If x = 50 Then
            If .Cells(i, j) <> "" And .Cells(i, j - 1) <> "" Then
                x = 0
                .Cells(i, j - 1).Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(2)
               
            Else: GoTo Skip
            End If
        End If
        If .Cells(i, j) <> "" And .Cells(i, j - 1) <> "" Then
            .Cells(i, j - 1).Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            x = x + 1
        End If
Skip:
            Next
    Next
End With
End Sub

 

[hiker95]

Here you go. I put your macro in it. https://drive.google.com/file/d/1JErtIzvsdwxiWvhgtQqU3Ah5QOOUtNah/view?usp=sharing

RobGEOD,

I have had problems in the past when attempting to download an Excel file with macros, with the xlsm file extension.

Please remove all macros, and, then rename the workbook using the xlsx file extension, and, then repost on dropbox.

 

[RobGEOD]

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

 

[RobGEOD]

poHere is one more try, using the even number columns.

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
With sh1
    For i = 2 To 50 Step 2
        For j = 2 To 51 'Assumes header row
        If x = 50 Then
            If .Cells(i, j) <> "" And .Cells(i, j - 1) <> "" Then
                x = 0
                .Cells(i, j - 1).Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(2)
               
            Else: GoTo Skip
            End If
        End If
        If .Cells(i, j) <> "" And .Cells(i, j - 1) <> "" Then
            .Cells(i, j - 1).Resize(1, 2).Copy sh2.Cells(Rows.Count, 1).End(xlUp)(2)
            x = x + 1
        End If
Skip:
            Next
    Next
End With
End Sub

Thanks but this didn't work and has some really strange results. I appreciate your response.
S