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