Sub Demo1()
Const D = "¤"
Dim V, VR(), L&, C&, R&, U&, W(1), F&
With Sheet4.[A1].CurrentRegion.Columns(1)
Range(.Cells(3), .Cells(.Cells.Count)).Sort .Cells(3), xlAscending, Header:=xlNo
.AdvancedFilter xlFilterCopy, , .Range("K1"), True
With .Range("K1").CurrentRegion
If .Count < 3 Then .Clear: Beep: Exit Sub
V = Range(.Cells(3), .Cells(.Count)).Value2
.Clear
End With
ReDim VR(1 To UBound(V), 1)
For L = 1 To UBound(V)
With .Range(.Find(V(L, 1), , , xlWhole), .Find(V(L, 1), , , , , xlPrevious)).Columns
If .Rows.Count = 1 Then
VR(L, 0) = Array(.Item(2).Value2)
VR(L, 1) = Array(.Item(4).Value2)
Else
VR(L, 0) = Filter(Application.Transpose(.Item(2)), "", True)
VR(L, 1) = Filter(Application.Transpose(.Item(4)), "", True)
End If
End With
Next
End With
With Sheet3.[A1].CurrentRegion.Rows
C = .Columns.Count - 2: If C < 1 Then Beep: Exit Sub
Application.ScreenUpdating = False
.Item("3:" & .Count).Columns(3).Resize(, C).Clear
V = Application.Match(.Columns(1), V, 0)
For R = 3 To .Count
If IsNumeric(V(R, 1)) Then
U = UBound(VR(V(R, 1), 0))
If U > -1 Then
If U < C Then
.Cells(R, 3).Resize(, U + 1).Value2 = VR(V(R, 1), 0)
For L = 0 To U: VR(V(R, 1), 1)(L) = VR(V(R, 1), 1)(L) - 1: Next
Else
.Cells(R, 3).Resize(, C).Value2 = VR(V(R, 1), 0)
For L = 0 To C - 1: VR(V(R, 1), 1)(L) = VR(V(R, 1), 1)(L) - 1: Next
W(0) = VR(V(R, 1), 0): W(1) = VR(V(R, 1), 1)
For L = 0 To U - C: VR(V(R, 1), 0)(L) = W(0)(C + L): VR(V(R, 1), 1)(L) = W(1)(C + L): Next
For F = 0 To C - 1: VR(V(R, 1), 0)(F + L) = W(0)(F): VR(V(R, 1), 1)(F + L) = W(1)(F): Next
End If
F = 0
For L = 0 To U
If VR(V(R, 1), 1)(L) < 1 Then F = 1: VR(V(R, 1), 0)(L) = D: VR(V(R, 1), 1)(L) = D
Next
If F Then For L = 0 To 1: VR(V(R, 1), L) = Filter(VR(V(R, 1), L), D, False): Next
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub