Hi.. Done..
Press the "Do It!" button to see results..
Private Sub CommandButton1_Click()
Dim Cell, z, x, J As Long, k As Long
For Each Cell In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
x = Cell.Offset(, 1).Resize(, 51).Value
Cells(1, 85).Resize(50).Value = Application.Transpose(x)
z = Application.Max(Columns(85).SpecialCells(2).Areas.Count)
Cell.Offset(, 52).Value = z
J = 1
For Each Area In Columns(85).SpecialCells(2).Areas
Cell.Offset(, 52 + J).Value = Area.Count
J = J + 1
Next Area
Next Cell
Columns(85).ClearContents
Dim Last As Long
Last = Cells.Find("*", SearchOrder:=xlByColumns, _
LookIn:=xlValues, SearchDirection:=xlPrevious).Column - 54
For k = 1 To Last
Cells(1, 54 + k).Value = "Res" & k
Next k
End Sub
Bookmarks