Code: Select all
Sub STEP12()
Application.ScreenUpdating = False
Dim LastRow As Long, lCol As Long, x As Long, srcWS As Worksheet, desWS As Worksheet
Dim Wb As Workbook
Set Wb = Activeworkbook
Set srcWS = Wb.Worksheets.Item(1)
Set desWS = Wb.Worksheets.Item(2)
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For x = 2 To LastRow
With srcWS
lCol = .Cells(x, .Columns.Count).End(xlToLeft).Column
If lCol - 2 >= 5 Then
desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1).Resize(, 3) = Array(.Cells(x, 1), .Cells(x, 2), lCol - 2)
End If
End With
Next x
Application.DisplayAlerts = False
wb.save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
plz see the sample file