How to combine many ranges into one big table with vba? (and remove all of the headin

[WorkGuy]

Hi guys,
Every month i get a few huge files with hundreds or thousands of rows where there are multiple ranges i have to manually combine into one big table. How can i do this with VBA?

1. Picture 1 (What i receive, though number of rows per range and number of ranges can vary) - https://gyazo.com/1427fe880cb865ef99cd59823213b109
2. Picture 2 (All ranges combined, text above ranges added to the last column, headings removed in all of the ranges except the first) - https://gyazo.com/efe595e932f15864c78fd9f96ad32ae3
3. Picture 3 (Formatting removed. Range made into a table) - https://gyazo.com/9436794709a5b35e837d3af6a2adaecb

I've tried watching tutorial on autofill, but i think they mostly take into consideration that there aren't multiple ranges/tables stacked on top of each other...

Example file without VBA code: backup vba.xlsx

[Paul_Hossler]

It's always better to attach a workbook with sample data, inputs and desired results instead of attaching a bunch of pictures

It's a more accurate description and it also saves people the effort of having to create something to test

Try this and let me know. It's a little more wordy that it needs to be and I left in, but commented out some intermediate results

Option Explicit


Sub Cleanup()
    Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range
    Dim rBlanks As Range
    Dim iArea As Long


    Application.ScreenUpdating = False


    'find data
    With Worksheets("Test")
    
        Set rFirst = .Cells(7, 2)
        Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
        Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
        
        Set rData = Range(rFirst, rEnd)
        'MsgBox rData.Address


        
        On Error Resume Next
        Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
        'MsgBox rBlanks.Address
        
        
        'best to go bottoms up
        For iArea = rBlanks.Areas.Count To 2 Step -1
'            MsgBox rBlanks.Areas(iArea).EntireRow.Resize(3).Address
            rBlanks.Areas(iArea).EntireRow.Resize(3).Delete
        Next iArea
        
        'special treatment for first block
        rBlanks.Areas(1).Offset(1, 0).EntireRow.Delete


        On Error GoTo 0


        .ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub

[WorkGuy]

It's always better to attach a workbook with sample data, inputs and desired results instead of attaching a bunch of pictures

It's a more accurate description and it also saves people the effort of having to create something to test

Try this and let me know. It's a little more wordy that it needs to be and I left in, but commented out some intermediate results

Option Explicit


Sub Cleanup()
    Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range
    Dim rBlanks As Range
    Dim iArea As Long


    Application.ScreenUpdating = False


    'find data
    With Worksheets("Test")
    
        Set rFirst = .Cells(7, 2)
        Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
        Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
        
        Set rData = Range(rFirst, rEnd)
        'MsgBox rData.Address


        
        On Error Resume Next
        Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
        'MsgBox rBlanks.Address
        
        
        'best to go bottoms up
        For iArea = rBlanks.Areas.Count To 2 Step -1
'            MsgBox rBlanks.Areas(iArea).EntireRow.Resize(3).Address
            rBlanks.Areas(iArea).EntireRow.Resize(3).Delete
        Next iArea
        
        'special treatment for first block
        rBlanks.Areas(1).Offset(1, 0).EntireRow.Delete


        On Error GoTo 0


        .ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub

Thanks. I'll try this right away. I did attach a file, but didnt do it until 10-15 minutes after i posted, so maybe you opened before i updated 😅

[WorkGuy]

It's always better to attach a workbook with sample data, inputs and desired results instead of attaching a bunch of pictures

It's a more accurate description and it also saves people the effort of having to create something to test

Try this and let me know. It's a little more wordy that it needs to be and I left in, but commented out some intermediate results

Option Explicit


Sub Cleanup()
    Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range
    Dim rBlanks As Range
    Dim iArea As Long


    Application.ScreenUpdating = False


    'find data
    With Worksheets("Test")
    
        Set rFirst = .Cells(7, 2)
        Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
        Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
        
        Set rData = Range(rFirst, rEnd)
        'MsgBox rData.Address


        
        On Error Resume Next
        Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
        'MsgBox rBlanks.Address
        
        
        'best to go bottoms up
        For iArea = rBlanks.Areas.Count To 2 Step -1
'            MsgBox rBlanks.Areas(iArea).EntireRow.Resize(3).Address
            rBlanks.Areas(iArea).EntireRow.Resize(3).Delete
        Next iArea
        
        'special treatment for first block
        rBlanks.Areas(1).Offset(1, 0).EntireRow.Delete


        On Error GoTo 0


        .ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub

I get "Subscript out of range" as i get to "Set rFirst = .Cells(7, 2)"

[WorkGuy]

It's always better to attach a workbook with sample data, inputs and desired results instead of attaching a bunch of pictures

It's a more accurate description and it also saves people the effort of having to create something to test

Try this and let me know. It's a little more wordy that it needs to be and I left in, but commented out some intermediate results

Option Explicit


Sub Cleanup()
    Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range
    Dim rBlanks As Range
    Dim iArea As Long


    Application.ScreenUpdating = False


    'find data
    With Worksheets("Test")
    
        Set rFirst = .Cells(7, 2)
        Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
        Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
        
        Set rData = Range(rFirst, rEnd)
        'MsgBox rData.Address


        
        On Error Resume Next
        Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
        'MsgBox rBlanks.Address
        
        
        'best to go bottoms up
        For iArea = rBlanks.Areas.Count To 2 Step -1
'            MsgBox rBlanks.Areas(iArea).EntireRow.Resize(3).Address
            rBlanks.Areas(iArea).EntireRow.Resize(3).Delete
        Next iArea
        
        'special treatment for first block
        rBlanks.Areas(1).Offset(1, 0).EntireRow.Delete


        On Error GoTo 0


        .ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub

Now that i changed my sheet name to "test" it kind of worked. The only thing is that it doesn't add the text above each of the ranges to the last column. I think it only removes the blank spaces and headings.

[p45cal]

In the attached, a Power Query offering.
This is a new workbook that interrogates the backup vba.xlsx file that you attached.
Because that workbook of yours contained 3 sheets being various stages of transformation, the query in the attached restricts itself to looking only at Sheet1; I imagine that your files will only contain one worksheet so that may have to be tweaked.
I suggest trialling this first by interrogating that same file on your system, but you'll need to adjust cell A1 (it is highlighted yellow and is a named range myPath) in the attached to the actual path to that file on your system.
Once that's done you'll need to refresh both tables, either by clicking on the Refresh All button in the Queries & Connections section of the Data tab of the ribbon, or by right-clicking each table and choosing Refresh.

A small difference (which might be a mistake on your part) is the last column: In your examples you have sequential numbering, but only for the first section:
2024-02-11_164109.jpg
I can do this, but I expect you want it for all sections, or none.

If you have multiple files to deal with in one go, I can do this too - this one works with just one file.

Do you receive these files as Excel workbooks, or in some other form? Say a txt or csv file? If so it'll be more straightforward and robust to interrogate those files directly.

[WorkGuy]

Learning VBA - Macro 1 - HeadingToRows.xlsm

I've been working on this a couple of hours now. Is this something that is usable? Can this be looped in some way?
https://gyazo.com/22f32753487cd05bfb83687c09d8a7e7

[Paul_Hossler]

Try this version

I've marked where you need to change the worksheet name

Option Explicit

Sub Cleanup()
    Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range, rArea As Range
    Dim rBlanks As Range
    Dim iArea As Long
    Dim sHeading As String


    Application.ScreenUpdating = False


    'find data
    With Worksheets("Test")
'    With ActiveSheet
'    With Worksheets("Whatever it is named")
    
        Set rFirst = .Cells(7, 2)
        Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
        Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
        
        Set rData = Range(rFirst, rEnd)
        'MsgBox rData.Address


        Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
        'MsgBox rBlanks.Address
        
        
        For iArea = 1 To rBlanks.Areas.Count
            With rBlanks.Areas(iArea)
                Set rFirst = .Offset(1, 0)
                sHeading = rFirst.Value
                
                Set rFirst = rFirst.Offset(2, 0)
                Set rLast = rFirst.End(xlDown)
                Set rEnd = rLast.End(xlToRight).Offset(0, 1)
                Set rArea = Range(rFirst, rEnd)
        
                rArea.Columns(rArea.Columns.Count).Value = sHeading
        
            End With
        Next iArea
        
        'best to go bottoms up
        For iArea = rBlanks.Areas.Count To 2 Step -1
            With rBlanks.Areas(iArea)
'               MsgBox .EntireRow.Resize(3).Address
                .EntireRow.Resize(3).Delete
            End With
        Next iArea
        
        'special treatment for first block
        With rBlanks.Areas(1)
            .Offset(1, 0).EntireRow.Delete
            .Offset(1, 0).End(xlToRight).Offset(0, 1).Value = "HEADING"
        End With


        On Error GoTo 0


        .ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub

[WorkGuy]

Try this version

I've marked where you need to change the worksheet name

Option Explicit

Sub Cleanup()
    Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range, rArea As Range
    Dim rBlanks As Range
    Dim iArea As Long
    Dim sHeading As String


    Application.ScreenUpdating = False


    'find data
    With Worksheets("Test")
'    With ActiveSheet
'    With Worksheets("Whatever it is named")
    
        Set rFirst = .Cells(7, 2)
        Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
        Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
        
        Set rData = Range(rFirst, rEnd)
        'MsgBox rData.Address


        Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
        'MsgBox rBlanks.Address
        
        
        For iArea = 1 To rBlanks.Areas.Count
            With rBlanks.Areas(iArea)
                Set rFirst = .Offset(1, 0)
                sHeading = rFirst.Value
                
                Set rFirst = rFirst.Offset(2, 0)
                Set rLast = rFirst.End(xlDown)
                Set rEnd = rLast.End(xlToRight).Offset(0, 1)
                Set rArea = Range(rFirst, rEnd)
        
                rArea.Columns(rArea.Columns.Count).Value = sHeading
        
            End With
        Next iArea
        
        'best to go bottoms up
        For iArea = rBlanks.Areas.Count To 2 Step -1
            With rBlanks.Areas(iArea)
'               MsgBox .EntireRow.Resize(3).Address
                .EntireRow.Resize(3).Delete
            End With
        Next iArea
        
        'special treatment for first block
        With rBlanks.Areas(1)
            .Offset(1, 0).EntireRow.Delete
            .Offset(1, 0).End(xlToRight).Offset(0, 1).Value = "HEADING"
        End With


        On Error GoTo 0


        .ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub

This works great, thanks! It can't handle if there's only one row in any of the ranges, but at least that isn't that often. I've learned a lot from this code though. Greatly appreciated!

[Paul_Hossler]

Added check for only single row

(Suggestion / Tip: BTW, it's not always necessary to [Reply With Quote]. Sometimes I do if multple members are posting so that my answer goes to the correct person, but I usually edit out the oft times lengthy code that was in the quoted post)

Any issues, question, or special conditions (e.g. 1 row) please feel free to come back

Option Explicit

Sub Cleanup()
    Dim rFirst As Range, rLast As Range, rEnd As Range, rData As Range, rArea As Range
    Dim rBlanks As Range
    Dim iArea As Long
    Dim sHeading As String


    Application.ScreenUpdating = False


    'find data
    With Worksheets("Test")
'    With ActiveSheet
'    With Worksheets("Whatever it is named")
    
        Set rFirst = .Cells(7, 2)
        Set rLast = .Cells(.Rows.Count, 2).End(xlUp)
        Set rEnd = .Cells(rLast.Row, .Columns.Count).End(xlToLeft)
        
        Set rData = Range(rFirst, rEnd)
        'MsgBox rData.Address


        Set rBlanks = rData.Columns(1).SpecialCells(xlCellTypeBlanks)
        'MsgBox rBlanks.Address
        
        
        For iArea = 1 To rBlanks.Areas.Count
            With rBlanks.Areas(iArea)
                Set rFirst = .Offset(1, 0)
                sHeading = rFirst.Value
                
                Set rFirst = rFirst.Offset(2, 0)
                'only single row of data since the next row/cell is blank <<<<<<<<<<<<<<<<<<<<<<<<<<<<
                If Len(rFirst.Offset(1, 0).Value) = 0 Then
                    Set rLast = rFirst
                Else
                    Set rLast = rFirst.End(xlDown)
                    Set rEnd = rLast.End(xlToRight).Offset(0, 1)
                End If
                Set rEnd = rLast.End(xlToRight).Offset(0, 1)
                Set rArea = Range(rFirst, rEnd)
        
                rArea.Columns(rArea.Columns.Count).Value = sHeading
        
            End With
        Next iArea
        
        'best to go bottoms up
        For iArea = rBlanks.Areas.Count To 2 Step -1
            With rBlanks.Areas(iArea)
'               MsgBox .EntireRow.Resize(3).Address
                .EntireRow.Resize(3).Delete
            End With
        Next iArea
        
        'special treatment for first block
        With rBlanks.Areas(1)
            .Offset(1, 0).EntireRow.Delete
            .Offset(1, 0).End(xlToRight).Offset(0, 1).Value = "HEADING"
        End With


        On Error GoTo 0


        .ListObjects.Add(xlSrcRange, rBlanks.Areas(1).Offset(1, 0).CurrentRegion, , xlYes).Name = "Table1"
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"


End Sub