Super Stuck - Combining Horizontal Sets of Data into One Vertical Table

[rdetreville]

Hello! First of all, I would like to say this website has been my saving grace for years. I'm so happy it exists and have learned so very much from members of this forum for years now.

This is my first official post. I'm under the gun to finish a tool for my job and am at a brick wall.

I'm creating a report generation tool that grabs data from hundreds of separate workbooks on a server and merges them into one. I have been successful so far and my data is now aligned on one worksheet and I have written all sorts of macros to clean up and scrub the data. What I'm left with now is basically repeating types of data (tables almost) going horizontally across the worksheet, with the same column headers: "Tracker Name" , "Team Member" , and then Month-Year columns: "May-2015", "June-2015", etc. I've attached a picture if this helps. All sets of data start with the "Tracker Name" and "Team Member" column and all begin with the same month but have different amounts of months after the first month column (some more, some less). All clusters are separated by a blank column.

I've now got to get the data into one big vertical table, so that I can create a PivotTable and actually use the data. I'm so close!

I've brainstormed countless ways to make this happen, and have come close with some methods, but am still stuck.

The primary way I've been attempting was to loop through the header row, find every instance of "Tracker Name" (the first column for each cluster) and then use the "ActiveCell.CurrentRegion.Select" feature to grab each "table" and actually turn it into a table. Then I was thinking I could delete all data not in a table and then somehow "stack" all the tables on top of each other on a new worksheet, all alligning in Column 1, and then turn all the tables back to ranges, remove the duplicate headers. But when I have tried various methods to find each cluster, and then select the current region, it messes up my being able to find the next cluster

Example code:

Sub govert2()

Dim lColumn As Long
Dim iCntr As Long
Dim myrange As Range

lColumn = 10000
For iCntr = lColumn To 1 Step -1
    
    If Cells(1, iCntr).Value = "Tracker Name" Then ActiveCell.Select
      
    If Cells(1, iCntr).Value = "Tracker Name" Then ActiveCell.CurrentRegion.Select
    
    If Cells(1, iCntr).Value = "Tracker Name" Then ActiveSheet.ListObjects.Add(xlSrcRange, Selection, , xlYes).Name = “Table2”
    
    Next

End Sub

I can see the data I need right in front of me! I just need to "stack" these columns on top of each other. A picture of my data is below. If anyone could help, I would be most appreciative. Thanks!!!

Richard

 

[rdetreville]

I did an F8 step-by-step walk-through and found the problem. Some of the CurrentRegions being copied only have one or two columns of data, and if there is a straggler row from the previous data set, the small-columned next CurrentRegion paste is getting mixed in with that data set.

I wonder the best way to fix this. As each CurrentRegion is pasted, is there any way after the paste to have VBA find the first blank row (or maybe two to be safe) in Column A and have excel delete the entire column or clear the let's say 30 cells to the right of that blank space? It might slow down the process, but it seems necessary.

This merged document was created using Ron de Bruin's merging add-in tool, if that's any help. Otherwise I could maybe try to hunt down the original merge code he used and see if I can delete the blank rows at that point. Picture below. Other than that - this is working perfectly. I have such respect for your knowledge - I want to be just like you some day!

Richard

 

[rdetreville]

Actually - perhaps I can modify your code .Offset(1).Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1) to have it paste the data let's say three or four blank rows down. And then I could have a small tacked-on code at the end to run down Column A and delete any row with nothing in column A. I can probably figure out the code for that - I'll give it a shot, unless you have a simple solution from my response above. Thanks!

 

[rdetreville]

I think I'm home free! I changed your code .Offset(1).Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(4)

and then appended:

Range("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

and it looks like it did the trick!!

Thank you again so much for your help AlphaFrog!

 

[AlphaFrog]

Ah, it's just the remanent data in the adjacent columns to column A. I see you figured it out. Well done.

This may be a little faster than deleting blank rows. It clears 100 rows below the last used row in column A before pasting.

[color=darkblue]Sub[/color] govert2()
    
    [color=darkblue]Dim[/color] Found [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] FirstFound [color=darkblue]As[/color] [color=darkblue]String[/color]
    [color=darkblue]Dim[/color] ws [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] rngHeaders [color=darkblue]As[/color] Range
    
    Application.ScreenUpdating = [color=darkblue]False[/color]
    [color=darkblue]Set[/color] ws = ActiveSheet
    Sheets.Add After:=ActiveSheet
    
    [color=darkblue]Set[/color] Found = ws.Rows(1).Find("Tracker Name", , , xlWhole, 1, 1, 0)
    
    [color=darkblue]If[/color] [color=darkblue]Not[/color] Found [color=darkblue]Is[/color] [color=darkblue]Nothing[/color] [color=darkblue]Then[/color]
        FirstFound = Found.Address
        [color=darkblue]Set[/color] rngHeaders = Found
        [color=darkblue]Do[/color]
            [color=darkblue]With[/color] Found.CurrentRegion
                [B]Range("A" & Rows.Count).End(xlUp).Offset(1).Rows("1:100").ClearContents[/B]
                .Offset(1).Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1)
                [color=darkblue]If[/color] rngHeaders.Count < .Rows(1).Cells.Count [color=darkblue]Then[/color] [color=darkblue]Set[/color] rngHeaders = .Rows(1).Cells
            [color=darkblue]End[/color] [color=darkblue]With[/color]
            [color=darkblue]Set[/color] Found = ws.Rows(1).FindNext(After:=Found)
        [color=darkblue]Loop[/color] [color=darkblue]Until[/color] Found.Address = FirstFound
        rngHeaders.Copy Destination:=Range("A1")
    [color=darkblue]Else[/color]
        MsgBox "Cannot find header ""Tracker Name""."
    [color=darkblue]End[/color] [color=darkblue]If[/color]
    
    Application.ScreenUpdating = [color=darkblue]True[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[rdetreville]

Ah, it's just the remanent data in the adjacent columns to column A. I see you figured it out. Well done.

This may be a little faster than deleting blank rows. It clears 100 rows below the last used row in column A before pasting.

[COLOR=darkblue]Sub[/COLOR] govert2()
    
    [COLOR=darkblue]Dim[/COLOR] Found [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] FirstFound [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] ws [COLOR=darkblue]As[/COLOR] Worksheet
    [COLOR=darkblue]Dim[/COLOR] rngHeaders [COLOR=darkblue]As[/COLOR] Range
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    [COLOR=darkblue]Set[/COLOR] ws = ActiveSheet
    Sheets.Add After:=ActiveSheet
    
    [COLOR=darkblue]Set[/COLOR] Found = ws.Rows(1).Find("Tracker Name", , , xlWhole, 1, 1, 0)
    
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] Found [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
        FirstFound = Found.Address
        [COLOR=darkblue]Set[/COLOR] rngHeaders = Found
        [COLOR=darkblue]Do[/COLOR]
            [COLOR=darkblue]With[/COLOR] Found.CurrentRegion
                [B]Range("A" & Rows.Count).End(xlUp).Offset(1).Rows("1:100").ClearContents[/B]
                .Offset(1).Copy Destination:=Range("A" & Rows.Count).End(xlUp).Offset(1)
                [COLOR=darkblue]If[/COLOR] rngHeaders.Count < .Rows(1).Cells.Count [COLOR=darkblue]Then[/COLOR] [COLOR=darkblue]Set[/COLOR] rngHeaders = .Rows(1).Cells
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
            [COLOR=darkblue]Set[/COLOR] Found = ws.Rows(1).FindNext(After:=Found)
        [COLOR=darkblue]Loop[/COLOR] [COLOR=darkblue]Until[/COLOR] Found.Address = FirstFound
        rngHeaders.Copy Destination:=Range("A1")
    [COLOR=darkblue]Else[/COLOR]
        MsgBox "Cannot find header ""Tracker Name""."
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Works like a charm! Thanks!!