Sub FlatList()
Dim arr As Variant
Dim r As Long, c As Long
Dim Results() As Variant
Dim DestR As Long
arr = Range("a1", Range("a1").SpecialCells(xlCellTypeLastCell)).Value
ReDim Results(1 To (UBound(arr, 1) - 1) * (UBound(arr, 2) - 1), 1 To 3) As Variant
For r = 2 To UBound(arr, 1)
For c = 2 To UBound(arr, 2)
DestR = DestR + 1
Results(DestR, 1) = arr(1, c)
Results(DestR, 2) = arr(r, 1)
Results(DestR, 3) = arr(r, c)
Next
Next
Worksheets.Add
Cells(1, 1).Resize(UBound(Results, 1), UBound(Results, 2)) = Results
Cells(1, 1).Sort Key1:=Cells(1, 1), Key2:=Cells(1, 2), Order1:=xlAscending, Order2:=xlAscending, _
Header:=xlNo
End Sub
|