Alternative
See Code:-
Sub MG14Nov23
Dim Rng As Range
Dim Dn As Range
Dim Dic As Object
Dim RwRng As Range
Dim Ws As Worksheet
Dim nRng As Range
Dim Ray()
Dim Ac As Range
Dim c As Long
Dim oMax As Long
With Sheets("Master (Expected Results)") ' change Name as required
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
End With
Set Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare
For Each Dn In Rng
Dic(Dn.Value) = Dn.Row
Next
For Each Ws In Worksheets
If Not Ws.Name = "Master (expected results)" Then ' change Name as required
With Ws
Set nRng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
c = oMax + 1
For Each Dn In nRng
Set RwRng = Ws.Range(Ws.Range("B" & Dn.Row), Ws.Cells(Dn.Row, Columns.Count).End(xlToLeft))
For Each Ac In RwRng
If Ac.Column + c - 2 >= oMax Then
ReDim Preserve Ray(1 To Rng.Count, 1 To Ac.Column + c - 2)
End If
Ray(Dic(Dn.Value), Ac.Column + c - 2) = Ac
oMax = Application.Max(Ac.Column + c - 2, oMax)
Next Ac
Next Dn
End If
Next Ws
Sheets("Master (expected results)").Range("B1").Resize(Dic.Count, oMax) = Ray ' change Name as required
End Sub
Regards Mick
Bookmarks