Originally Posted by
mthwi
I guess these blanks were in the other workbooks as well?
No, none of the original spec source data had blank headers for your primary column AND blanks between table regions. It makes it very difficult to work out what the table regions actually are, when they're inconsistent. This latest dataset also doesn't have an value to indicate the end of the rows, either.
Try this - it test okay for me on all the datasets you've provided so far:
Sub foo()
Dim lCount As Long
Dim lCols As Long
Dim lRows As Long
Dim l As Long
Dim v As Variant
Dim ws As Worksheet
Dim c As Range
Dim dic As Object
For Each ws In ThisWorkbook.Worksheets
Set dic = CreateObject("Scripting.Dictionary")
With ws
Do Until .UsedRange.Rows(1).Row = 1
.Rows(1).EntireRow.Delete
Loop
Set c = .Range("A1")
v = c.Value
Do Until v <> ""
Set c = c.Offset(0, 1)
v = c.Value
Loop
lCount = Application.CountIf(.UsedRange.Rows(1), v)
lCols = .UsedRange.Rows(1).Find(what:=v, After:=c).Column - c.Column
Set c = Nothing
For l = 1 To lCols * lCount Step lCols
Set c = .UsedRange.Columns(l).Find(what:="Total", LookAt:=xlPart)
If c Is Nothing Then Set c = .UsedRange.Columns(l).Find(what:="* Estimated", LookAt:=xlPart)
If c Is Nothing Then Set c = .UsedRange.Cells(.UsedRange.Rows.Count, 1).Offset(1, 0)
If Not c Is Nothing Then
lRows = c.Row - 2
.Cells(2, l).Resize(lRows, lCols).Sort Key1:=.Cells(2, l), Order1:=xlAscending, Header:=xlNo
For Each c In .Cells(2, l).Resize(lRows, 1)
If c.Value <> "" Then dic(c.Value) = c.Value
Next c
End If
Next l
Set dic = SortDic(dic)
For l = 1 To lCols * lCount Step lCols
For lRows = 0 To dic.Count - 1
With .Cells(lRows + 2, l)
If Not .Value = dic.items()(lRows) Then
.Resize(1, lCols).Insert shift:=xlDown
End If
End With
Next lRows
Next l
End With
Set dic = Nothing
Next ws
End Sub
Public Function SortDic(dic As Object) As Object
Dim s() As String
Dim v As Variant
Dim i As Integer
Dim j As Integer
If dic.Count > 1 Then
ReDim s(dic.Count)
i = 0
For Each v In dic
s(i) = v
i = i + 1
Next
For i = 0 To (dic.Count - 2)
For j = (i + 1) To (dic.Count - 1)
If s(i) > s(j) Then
v = s(j)
s(j) = s(i)
s(i) = v
End If
Next
Next
Set SortDic = CreateObject("Scripting.Dictionary")
For i = 0 To (dic.Count - 1)
SortDic.Add s(i), dic(s(i))
Next
Else
Set SortDic = dic
End If
End Function
Bookmarks