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?


Picture 1 (What i receive, though number of rows per range and number of ranges can vary) - https://gyazo.com/1427fe880cb865ef99cd59823213b109
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
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: 31339

[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:
31341
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]

31343

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