Sub test()
Dim myAreas As Areas, r As Range, c As Range, s$, sp As Shape, HD()
Dim a, i&, ws As Worksheet, myNames, dic As Object, xx As Single
xx = Timer
Set dic = CreateObject("Scripting.Dictionary")
Set ws = Sheets.Add
ws.UsedRange.Clear
For Each sp In ws.Shapes
sp.Delete
Next
Set myAreas = Sheets("master tab").Rows(3).SpecialCells(2).Areas
ReDim myNames(1 To myAreas.Parent.Parent.UsedRange.Count), HD(1 To 2)
HD(1) = myAreas(1).Cells(1): HD(2) = myAreas(1).Cells(2)
For Each r In myAreas
Set c = r.CurrentRegion
a = c.Value
For i = 3 To UBound(a, 2)
ReDim Preserve HD(1 To UBound(HD) + 1): HD(UBound(HD)) = a(1, i)
Next
For i = 2 To UBound(a, 1)
If a(i, 1) <> "" Then
s = Join(Array(a(i, 1), a(i, 2)), Chr(2))
If Not dic.exists(s) Then
Set dic(s) = c(i, 1).Resize(c(i, 1).MergeArea.Rows.Count, UBound(a, 2))
myNames(dic.Count) = s
End If
End If
Next
Next
ReDim Preserve HD(1 To UBound(HD) + 1): HD(UBound(HD)) = "Notes"
ReDim Preserve myNames(1 To dic.Count)
mySort myNames, 1, UBound(myNames)
GetAllData myAreas, HD, myNames, dic, ws, 4
MsgBox Timer - xx
End Sub
Sub GetAllData(myAreas As Areas, HD, myNames, dic As Object, ws As Worksheet, x&)
Dim a, i&, ii&, t&, s$, c As Range, n&, ff$
Application.ScreenUpdating = False
n = x
For i = 1 To UBound(myNames)
s = myNames(i)
dic(s).Copy ws.Cells(n, 3)
Set dic(s) = ws.Cells(n, 3)
n = n + dic(s).Cells(1).MergeArea.Rows.Count
Next
For i = 2 To myAreas.Count
Set c = myAreas(i).CurrentRegion
a = c.Value: t = t + myAreas(i - 1).CurrentRegion.Columns.Count - 2
For ii = 2 To UBound(a, 1)
If a(ii, 1) <> "" Then
s = Join(Array(a(ii, 1), a(ii, 2)), Chr(2))
c(ii, 3).Resize(c(ii, 1).MergeArea.Rows.Count, UBound(a, 2) - 2).Copy dic(s).Cells(1, t + 4 - 1)
End If
Next
Next
ws.UsedRange.Font.Size = 12
Set c = ws.Cells.Find("not on file", , , 1)
Application.DisplayAlerts = False
If Not c Is Nothing Then
ff = c.Address
Do
c.Resize(c.EntireRow.Range("c1").MergeArea.Rows.Count).Merge
Set c = ws.Cells.FindNext(c)
Loop While ff <> c.Address
End If
Application.DisplayAlerts = True
With ws.Cells(x - 1, 3).Resize(, UBound(HD))
.Value = HD
.HorizontalAlignment = xlCenter
.Font.Bold = True: .Font.Color = vbWhite
.Interior.Color = 3484450
.Borders(11).Weight = 2
.Borders(11).Color = vbWhite
.WrapText = True
End With
ws.Columns.AutoFit
ws.Rows.AutoFit
ws.Cells.Copy Sheets("master tab").[a1]
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub mySort(Ary, LB, UB)
Dim i As Long, ii As Long, M, temp
i = UB: ii = LB
M = Ary(Int((LB + UB) / 2))
Do While ii <= i
Do While Ary(ii) < M: ii = ii + 1: Loop
Do While Ary(i) > M: i = i - 1: Loop
If ii <= i Then
temp = Ary(i): Ary(i) = Ary(ii): Ary(ii) = temp
i = i - 1: ii = ii + 1
End If
Loop
If LB < i Then mySort Ary, LB, i
If ii < UB Then mySort Ary, ii, UB
End Sub
