VBA將工作簿中所有工作表中選定范圍內的已填充單元格復制到一個摘要工作表

Question

有人可以幫忙嗎？ 我正在尋找VBA宏，這將有助於我總結多種形式的數據。 但是我沒有發現任何對我有用的東西。

我的工作簿有大量的工作表。 這些工作表是由客戶填寫的表單（每個工作表稱為FORM_number）。 問題是人們沒有按正常順序填寫表格-從第一行（在我的情況下為A5）開始，但在任意范圍（A5：K30）范圍內（例如，從A：10開始，然后從A：15開始，然后是A：22和A：23）。 宏應該執行的任務是僅復制上述范圍內的填充行（例如：僅行10、15、22、23）並將其粘貼到“ Summary_Sheet”中-如此一來，第1個表格中就有4條記錄，然后7記錄來自第二個表單等。並且還應該將數字（來自表單名稱）添加到從該工作表復制的每個記錄的L列中。

不知道我是否足夠清楚，但是如果有人有時間幫助我，我將非常感激。

Answer 1

在OP闡明了有關初始輸入行索引之后進行了編輯：

您可以嘗試以下（注釋）代碼：

Option Explicit

Sub main()
    Dim sht As Worksheet, summarySht As Worksheet
    Dim rngToCopy  As Range

    With Workbooks("Forms") '<--| change "formsWb" to your actual workbook with "FORM_Number" sheets name
        Set summarySht = GetOrCreateSheet(.Worksheets, "Summary_Sheet") '<--|get Summary worksheet reference or create it if not already in referenced workbook
        For Each sht In .Worksheets '<-- loop through referenced workbook worksheets
            With sht '<-- reference current worksheet
                If Left(.name, 5) = "FORM_" Then '<-- if its name begins with "FORM_" then...
                    Set rngToCopy = .Columns(1).SpecialCells(XlCellType.xlCellTypeConstants).EntireRow '<-- set the range of currently referenced worksheet column "A" not blank cell entire row
                    Set rngToCopy = Intersect(rngToCopy, .Rows("5:" & .UsedRange.Rows(.UsedRange.Rows.Count).row)) '<--| limit it to rows from row 5 downwards
                    rngToCopy.Copy '<-- copy the above set range
                    With summarySht '<-- reference Summary worksheet
                        With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) '<-- get its first blank cell in column "A"
                            .PasteSpecial '<-- paste the copied range
                            Application.CutCopyMode = False
                            .Offset(, 11).Resize(.Parent.Cells(.Parent.Rows.Count, 1).End(xlUp).row - .row + 1).Value = sht.name '<-- paste the current "FORM" worksheet name in column "L" corresponding rows
                        End With
                    End With
                End If
            End With
        Next sht
    End With
End Sub

Function GetOrCreateSheet(wss As sheets, shtName As String) As Worksheet
    With wss
        On Error Resume Next
        Set GetOrCreateSheet = .Item(shtName)
        On Error GoTo 0
        If GetOrCreateSheet Is Nothing Then
            Set GetOrCreateSheet = .Add
            .Parent.ActiveSheet.name = "Summary_Sheet"
        End If
    End With
End Function