复制非空文件

的数据

Option Explicit

Sub CopyNonBlankRows()
    
    ' Define constants.
    
    Const SRC_FIRST_ROW As String = "A2:L2"
    
    Const DST_SHEET As String = "Combined"
    Const DST_FIRST_CELL As String = "A2"
    
    Dim Exclusions():
    Exclusions = Array("Setup", "Combined", "Summary", "Drop Down Menus")

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the first destination row.
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET)
    Dim cCount As Long: cCount = dws.Range(SRC_FIRST_ROW).Columns.Count
    Dim dfrrg As Range:
    Set dfrrg = dws.Range(DST_FIRST_CELL).Resize(, cCount)
    
    ' Declare additional variables needed in the For...Next loop.
    
    Dim sws As Worksheet, srg As Range, slCell As Range
    Dim Data(), srCount As Long, sr As Long, dr As Long, c As Long

    ' Copy values of non-blank rows.

    ' Loop through all worksheets...
    For Each sws In wb.Worksheets
        ' Check if the source worksheet name is not in 'Exclusions'.
        If IsError(Application.Match(sws.Name, Exclusions, 0)) Then
            ' Clear filters to ensure the 'Find' method will not fail.
            If sws.FilterMode Then sws.ShowAllData
            ' Attempt to write the values to an array.
            With sws.Range(SRC_FIRST_ROW)
                ' Attempt to reference the last cell of the source range.
                Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
                    .Find("*", , xlValues, , xlByRows, xlPrevious)
                If Not slCell Is Nothing Then ' the source range is not blank
                    srCount = slCell.Row - .Row + 1
                    ' Write the values to an array.
                    Data = .Resize(srCount).Value
                'Else ' the source range is blank; do nothing
                End If
            End With
            If srCount > 0 Then ' the source range is not blank
                ' Write the non-blank rows to the top of the array.
                For sr = 1 To srCount
                    For c = 1 To cCount
                        If Len(CStr(Data(sr, c))) > 0 Then
                            Exit For
                        End If
                    Next c
                    If c <= cCount Then
                        dr = dr + 1
                        For c = 1 To cCount
                            Data(dr, c) = Data(sr, c)
                        Next c
                    End If
                Next sr
                ' Write the values from the top of the array
                ' to the destination worksheet.
                dfrrg.Resize(dr).Value = Data
                ' Reset for the next iteration.
                Set dfrrg = dfrrg.Offset(dr)
                dr = 0
                srCount = 0
            'Else ' the source range is blank; do nothing
            End If
        'Else ' it's a worksheet to be excluded; do nothing
        End If
    Next sws
    
    ' Clear previous data (if any) below the result.
    
    dfrrg.Resize(dws.Rows.Count - dfrrg.Row + 1).Clear
    
    ' Inform.
     
    MsgBox "Non-blank rows copied.", vbInformation

End Sub

字符串