excel 复制和粘贴使用if isempty不按预期工作- VBA

fjaof16o  于 2023-05-19  发布在  其他
关注(0)|答案(1)|浏览(155)

我需要帮助与下面的VBA我试图运行。
我有多个工作表,其中可能有或可能没有数据。它们将始终在第1行中具有标题,但可能不总是具有从第2行开始的数据。
我想做的是浏览这些工作表,如果其中有数据,请将其复制到组合工作表中。
下面找到第一个工作表,第2行中有数据,并复制它的预期,但然后宏完成没有寻找在所有其他工作表,我不知道为什么?
非常感谢任何帮助,或者如果你有关于我在做什么的情况下,它不是完全可以理解的进一步问题!

For Each ws In ActiveWorkbook.Worksheets

    Select Case ws.Name
        Case "Setup", "Combined", "Summary", "Drop Down Menus"
        'do nothing
        
        Case Else
            Set wsDestination = ThisWorkbook.Worksheets("Combined")
                If IsEmpty(Range("A2").Value) Then
                    'find the last row
                    lrow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
                        With wsDestination
                            ws.Range("A2:L" & lrow).Copy Destination:=.Range("A" & .Rows.Count).End(xlUp).Offset(1)
                        End With
                End If
    End Select
Next
db2dz4w8

db2dz4w81#

复制非空行

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

相关问题