如何运行 VBA 循环来格式化每个工作表并创建摘要选项卡

Posted 2023-03-29

【中文标题】如何运行 VBA 循环来格式化每个工作表并创建摘要选项卡

【英文标题】：How do you run a VBA loop to format each worksheet, and create a summary tab

【发布时间】：2020-06-09 18:24:27

【问题描述】：

我有一个包含 20 多个工作表的电子表格，其中列出了服务器。我正在尝试格式化每张工作表以仅提取前四列数据，同时保留原始数据。我在左侧插入 6 列，创建列标题，复制前四行数据（起始名称为“SERV-”），然后将工作表的名称放在第 5 列中。如果在一张纸上运行，我的代码可以正常工作。我试图把它放在一个循环中，但它不起作用。它仅在第一个工作表中插入列和标题。

一旦我让这个循环工作，我想创建一个摘要选项卡，它将每张工作表的前五行中的数据拉到摘要选项卡中。这应该很容易，但我还没有在代码中达到这一点。

这是我目前的代码：

'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

【问题讨论】：

您只是在循环内以非常不完整的方式使用 With - Range/Cells 等的 每个实例 等都需要在 @ 987654325@ 块并以 . 为前缀以将其绑定到 With，或由 ws 显式限定

不要使用选择。

我不确定如何使用前缀。绑定到 With。我也不知道没有选择该怎么办。我将不得不重建其中的大部分。

【参考方案1】：

除非您有其他原因，否则只需扫描表格并将数据复制到摘要中可能更容易。

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

【讨论】：

我试过这段代码，但它卡在第 12 行“Set wsSum = wb.Sheets(SUM_SHEET)”。电子表格由不同的团队在工作中管理，他们不愿意改变他们的流程，所以我必须适应。有时数据有空白行。并且在主标题下方还有其他行，说明客户端 ID 等。这就是为什么我要搜索以“SERV-”开头的项目作为服务器 ID#s。而且我需要工作表名称，以便摘要将客户端名称附加到每个服务器。

我没有创建摘要表。但是我按照你的要求添加了一个，我仍然得到同样的错误。

如果宏可以在我的个人工作簿中就好了，因为这是月度报告。但是，还有另一个问题。有些工作表是空白的，或者没有该客户端的服务器。宏因此停止并且没有继续。

@Josh 我已更新代码以使用 set wb = Activeworkbook，以便您可以将其放入个人 wb。尽管您仍然会收到一个消息框，但我已将退出子更改为 goto 以跳过空白工作表。

它成功了，只是需要一段时间才能运行。谢谢。