将非空行复制/剪切到顶行

Question

我的主要目标是能够编写一段代码来检查范围

A4:C7

之间的非空单元格（如果

A6

上有值），然后复制/剪切范围A6：C6并粘贴到范围

A4

如果

A5

和

B7

上有值，则复制/剪切范围

A5:C5

和

A7:C7

并将输出粘贴到范围

A4

我尝试了以下代码，但我不知道如何将其修复为我想要的正确操作。以下代码的缺陷是

1. 它不会检查 B4、B5、B6、B7 或 C4、C5、C6、C7 下的值
2. 如果它检测到 A4 中的值，它就不起作用（我希望它将该值覆盖到顶部，因为本质上我只是复制值的行

Sub CopyNonEmptyRowsToTopRows22()

    Dim rng As Range
    Dim i As Integer
    
    For i = 4 To 7
        If Not IsEmpty(Sheet4.Range("A" & i)) Then
            If rng Is Nothing Then
                Set rng = Sheet4.Range("A" & i & ":C" & i)
            Else
                Set rng = Union(rng, Range("A" & i & ":C" & i))
            End If
        End If
    Next i
    
    rng.Cut Sheet4.Range("A4")
End Sub

Answer 1

删除空白行

用法

Sub CopyNonEmptyRowsToTopRows22()
    RemoveBlankRows Sheet4.Range("A4:C7")
End Sub

方法

Sub RemoveBlankRows(ByVal rg As Range)

    Dim srCount As Long: srCount = rg.Rows.Count
    If srCount = 1 Then Exit Sub
    
    Dim cCount As Long: cCount = rg.Columns.Count
    Dim Data() As Variant: Data = rg.Value
    
    Dim sr As Long, dr As Long, c As Long, IsNotFound As Boolean
    
    ' Copy to top.
    For sr = 1 To srCount
        For c = 1 To cCount
            If Len(CStr(Data(sr, c))) > 0 Then Exit For ' non-blank row found
            'If IsEmpty(Data(sr, c)) Then Exit For ' non-empty row found
        Next c
        If c <= cCount Then ' non-blank row found
            dr = dr + 1
            If IsNotFound Then
                For c = 1 To cCount
                    Data(dr, c) = Data(sr, c)
                Next c
            End If
        Else
            IsNotFound = True
        End If
    Next sr
    
    If Not IsNotFound Then Exit Sub ' no blank row found
    
    ' Clear bottom.
    For sr = dr + 1 To srCount
        For c = 1 To cCount
            Data(sr, c) = Empty
        Next c
    Next sr
        
    rg.Value = Data

End Sub