VBA Copy filled cells in selected range in all sheets within the workbook to one summary sheet

Question

could anybody help please? I was searching for VBA macro which will help me to summarize data from many forms. But I didnt find anything which is working for me.

I have workbook with huge number of sheets. The sheets are forms, which were filled by customers (each sheet is called FORM_number). The problem is that people didnt fill up the forms in normal order - starting from the top row (in my case A5) but in a range (A5:K30) anywhere (example in row starting in A:10 and then A:15 and then A:22 and A:23). The task which the macro should do, is to copy only filled rows in the mentioned range (example: only row 10,15,22,23) and paste it to "Summary_Sheet" one by one - so 4 records from 1st form then 7 records from 2nd form etc. And it should also add the number (from form name) to the column L to each record which was copied from that sheet.

Not sure if I am clear enough, but if somebody will have time to help, I will be very grateful.

Answer 1

edited after OP's clarification about initial input row index:

you could try this (commented) code:

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