How do you run a VBA loop to format each worksheet, and create a summary tab

Question

I have a spreadsheet with 20+ worksheets listing servers. I am trying to format each sheet to pull only the first four columns of data, while preserving the original data. I am inserting 6 columns on the left, creating column headings, copying the first four rows of data (with starting name of "SERV-"), then putting the name of the worksheet in the 5th column. I got the code to work fine if ran in one sheet. I am trying to put it in a loop, but it isn't working. It is inserting the columns and headers in the first worksheet only.

Once I have this loop working, I want to create a summary tab where it pulls the data from these first five rows of each sheet into the summary tab. This should be easy, but I haven't gotten to that point in the code yet.

This is the code I have so far:

'PhaseOne of test code

Sub PhaseOne()
Dim ws As Worksheet
 Dim lngRow As Long
 Dim lngCount As Long
 lngRow = 8

 For Each ws In Worksheets


    '(2) Remove blank rows (WORKS)
        Dim x As Long
        With ws
            For x = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
                If WorksheetFunction.CountA(.Rows(x)) = 0 Then
                ws.Rows(x).Delete
                End If
            Next
        End With

    '(3) Insert 5 columns (WORKS)
        Columns("A:F").Insert Shift:=xlToRight

    '(4) Label columns (WORKS)
        Range("$A$1").Value = "ServLabel"
        Range("$B$1").Value = "Primary IP"
        Range("$C$1").Value = "DC"
        Range("$D$1").Value = "Service ID"
        Range("$E$1").Value = "Sheet"

    '(5) Find and Copy Range (WORKS)
        Dim lastRow As Long
        With ws
            lastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
        End With
        Dim rFound As Range
        On Error Resume Next
        Set rFound = Cells.Find(What:="SERV-", _
                    After:=Cells(Rows.Count, Columns.Count), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlNext, _
                    MatchCase:=False)
        On Error GoTo 0
        If rFound Is Nothing Then
        Else
            rFound.Select
            Selection.Resize(lastRow, numcolumns + 4).Select
            Selection.Copy
            Range("A2").Select
            ws.Paste
        End If

    '(8) Enter active sheet name in Column E (WORKS)
        If ws.Range("A2") = "" Then
        Else
            Dim lastRow2 As Long
            With ws
                lastRow2 = .Cells(.Rows.Count, "d").End(xlUp).Row
            End With
            Range("E2").Select
            Selection.Resize(lastRow2 - 1).Select
            Selection = ws.Name
        End If

    Next ws
End Sub

Answer 1

Unless you have some other reason it's probably easier to just scan the sheets and copy the data to the summary.

Option Explicit
Sub summary()

    Const SUM_SHEET = "Summary" ' name of smmary sheet
    Const PREFIX = "SERV-*"

    Dim wb As Workbook, ws As Worksheet, wsSum As Worksheet
    Dim iRow As Long, iSumRow As Long
    Dim iStartrow As Long, iLastRow As Long, rng As Range, cell As Range

    Set wb = ActiveWorkbook
    Set wsSum = wb.Sheets(SUM_SHEET)

    wsSum.Range("A1:E1") = Array("ServLabel", "Primary IP", "DC", "Service ID", "Sheet")
    iSumRow = 1

    For Each ws In wb.Sheets
        If ws.Name <> SUM_SHEET Then

            ' find column SERV-
            On Error Resume Next
            Set rng = ws.Cells.Find(PREFIX)
            On Error GoTo 0

            ' set scan start/end row
            If rng Is Nothing Then
                MsgBox "Can't find " & PREFIX & " on " & ws.Name, vbCritical
                GoTo SkipSheet
            Else
               iLastRow = ws.Cells(Rows.Count, rng.Column).End(xlUp).Row
               iStartrow = rng.Row + 1
            End If
            Debug.Print ws.Name, "Col=", rng.Column, "iStartRow=", iStartrow, "iLastRow=", iLastRow

            ' scan the sheet and write to summary
            For iRow = iStartrow To iLastRow
                Set cell = ws.Cells(iRow, rng.Column)

                ' skip blank line
                If Len(cell) > 0 Then
                    iSumRow = iSumRow + 1
                    cell.Resize(1, 4).Copy wsSum.Cells(iSumRow, 1)
                    wsSum.Cells(iSumRow, 5) = ws.Name
                End If                  
            Next
        End If
 SkipSheet:
    Next
    MsgBox iSumRow - 1 & " rows copied to " & wsSum.Name, vbInformation

End Sub