Sub Test()
Sub Test()
Dim a, i As Long, ii As Long, rw As Long, cl As Long, c As Long, z As New Collection
a = [a1].CurrentRegion.Value
For i = 2 To UBound(a)
c = 0
For ii = 3 To UBound(a, 2)
If a(i, ii) = "" Then
c = ii: Exit For
End If
Next ii
On Error Resume Next
If c > 0 Then z.Add Key:=a(i, 1), Item:=Array(i, c)
If Err Then
rw = z(a(i, 1))(0): cl = z(a(i, 1))(1)
For ii = cl To UBound(a, 2)
a(rw, ii) = a(i, ii): a(i, ii) = ""
Next ii
c = IIf(c < cl, c, cl)
z.Remove a(i, 1)
z.Add Key:=a(i, 1), Item:=Array(i, c)
Err.Clear
End If
On Error GoTo 0
Next i
'Change [h1] to [a1] if want in same location
[h1].Resize(UBound(a, 1), UBound(a, 2)).Value = a
End Sub
Bookmarks