将一个范围从一个工作表复制到另一个工作表，不带空白行

Question

我在工作表中指定了一个范围，该范围宽五列，长约 220 行。 该范围内的行主要是从其他位置提取数据并连接或以其他方式操作它的公式。 该范围中的某些行由完全空白的单元格（无公式）组成，或者可能包含不返回值的公式。

空白行总是有一个解析为无值的公式，或者在其所有单元格中根本没有公式。当一行为空时，该行中的所有单元格都满足该条件，因此可以在第一列中的单元格上进行测试，但测试必须在计算公式的值之后进行（否则单元格中的公式将被评估为“非空白”）

我想复制该范围并粘贴公式返回的值，省略任何空白行，从第二个工作表的单元格 E5 开始。

下面的代码执行了我想要的操作，只是它不省略空白行：

Sub RangeRefactor()

    Dim wsI As Worksheet

    Dim wsO As Worksheet

    Set wsI = ThisWorkbook.Sheets("InputSheet")

    Set wsO = ThisWorkbook.Sheets("OutputSheet")

    With Range("Refactor")

        .Copy

        wsO.Range("e5").PasteSpecial xlPasteValues

    End With

End Sub

我不知道如何在范围位于内存中和粘贴之前删除空白行。 我审查过的大多数解决方案都使用了一些方法，我认为这些方法会在复制范围之前删除 InputSheet 中的行，这是不需要的（即 SpecialCells(xlCellTypeBlanks).Select / Selection.EntireRow.Delete）

答案可能是在粘贴之前必须将范围加载到数组中进行操作，但我希望有一个更简单的方法，因为我已经很长很长一段时间没有使用数组了。 感谢您的帮助！

Answer 1

复制非空行的值

• 屏幕截图中的命名范围

  Refactor

  是包含此代码 (

  A2:D21

  ) 的工作簿中工作表

  InputSheet

  上的范围

  ThisWorkbook

  。
• 没有列可以用来确定行是否为空，因此代码会循环遍历每行的列，直到将整行复制到数组顶部时遇到非空值。如果所有值均为空，则会跳过该行。

主要

Sub CopyRefactor()

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim sws As Worksheet: Set sws = wb.Sheets("InputSheet")
    Dim srg As Range: Set srg = sws.Range("Refactor")
    
    Dim dws As Worksheet: Set dws = wb.Sheets("OutputSheet")
    Dim dcell As Range: Set dcell = dws.Range("E5")
    
    CopyNonBlankRows srg, dcell

End Sub

帮助

Sub CopyNonBlankRows(ByVal srg As Range, dcell As Range)

    Dim rCount As Long: rCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    
    Dim Data() As Variant
    
    If rCount + cCount = 2 Then
        ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
    Else
        Data = srg.Value
    End If
    
    Dim sr As Long, c As Long, drCount As Long
    
    For sr = 1 To rCount
        For c = 1 To cCount
            If Len(CStr(Data(sr, c))) > 0 Then Exit For
        Next c
        If c <= cCount Then
            drCount = drCount + 1
            For c = 1 To cCount
                Data(drCount, c) = Data(sr, c)
            Next c
        End If
    Next sr

    If drCount = 0 Then Exit Sub ' no non-blank rows found
    
    dcell.Resize(drCount, cCount).Value = Data

End Sub