Как запустить VBA l oop для форматирования каждого рабочего листа и создания сводной вкладки - PullRequest
Новая
       13

Как запустить VBA l oop для форматирования каждого рабочего листа и создания сводной вкладки

0 голосов
/ 26 февраля 2020

У меня есть электронная таблица с более чем 20 серверами. Я пытаюсь отформатировать каждый лист, чтобы извлечь только первые четыре столбца данных, сохраняя при этом исходные данные. Я вставляю 6 столбцов слева, создаю заголовки столбцов, копирую первые четыре строки данных (с начальным именем «SERV-»), затем помещаю имя листа в 5-й столбец. Я получил код, чтобы работать нормально, если запустить на одном листе. Я пытаюсь поместить это в al oop, но это не работает. Он вставляет столбцы и заголовки только в первый лист.

Как только у меня будет работать l oop, я хочу создать сводную вкладку, где она будет перетаскивать данные из этих первых пяти строк каждого листа в сводную вкладку. Это должно быть легко, но я еще не дошел до этого момента в коде.

Это код, который у меня есть: 

'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

1 Ответ

0 голосов
/ 26 февраля 2020

Если у вас нет другой причины, вероятно, проще просто отсканировать листы и скопировать данные в сводку. 

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
...