如果特定范围为空而另一个不为空，则复制-粘贴到行的范围上方 (VBA)

Question

大家早上好！

问题总结

所以我在完善和优化这里的代码时遇到了麻烦。我是新手，但我很确定这可以做得更好。

所以我有一个table在工作sheet。我想做的是：

扫描第 6 行的列 (A:M) 以查看所有单元格是否为空
如果是，则扫描第 6 行的列 (N:R) 以查看是否所有单元格都为空
如果 2. 为假，则复制上面行的第 6 行的列 (A:I)
重复 1-3 但在第 7 行

这个过程应该重复，直到 table 的行结束。我可能想合并的是 ActiveSheet.ListObjects(1).Name 或类似的东西，这样我就可以复制 sheet 而无需调整代码。

描述您尝试过的内容

我已经尝试了几个潜艇来尝试执行这个概念。我还没有想出的是如何使它尽可能高效和尽可能无风险。我的代码有效（我不完全确定它是否有任何问题）但它确实太多了。

我在下面发布以下代码。如果它太基本，请原谅我。我是 Excel VBA.

的新手

显示一些代码

Sub CopyPasteRow()
    Dim lr As Long
    Dim x As Long
    Dim y As Long
    Dim a As Long
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    a = 0
    For x = 6 To lr
        For y = 1 To 13
            If Not IsEmpty(Cells(x, y)) Then
                a = a + 1
            End If
        Next y
        If a = 0 Then
            For y = 14 To 18
                If Not IsEmpty(Cells(x, y)) Then
                    a = a + 1
                End If
            Next y
        Else
            a = 0
        End If
        If a <> 0 Then
                For y = 1 To 13
                    Cells(x, y).Value = Cells(x - 1, y).Value
                Next y
        End If
    a = 0
    Next x
End Sub

编辑

这是基于@CHill60代码的定稿代码。这不完全是我的目标，但让我达到了 99% 的目标。

Sub CopyPasteRow()
Dim lr As Long
Dim x As Long
Dim a As Long
Dim r As Range, r2 As Range, r3 As Range
lr = Cells(Rows.Count, 1).End(xlUp).Row
For x = 6 To lr
    'check columns A to M for this row are empty
        Set r = ActiveSheet.Range("A" & CStr(x) & ":M" & CStr(x))
    
    'check columns N to R for this row are empty
        Set r2 = ActiveSheet.Range("N" & CStr(x) & ":R" & CStr(x))
    
    If WorksheetFunction.CountA(r) = 0 And WorksheetFunction.CountA(r2) <> 0 Then
        'copy the data into columns A to M
        Set r3 = ActiveSheet.Range("A" & CStr(x) & ":I" & CStr(x))
        r3.Value = r3.Offset(-1, 0).Value
    End If
Next x
End Sub

非常感谢@CHill60。

Answer 1

与其查看单个单元格，不如查看范围。考虑这段代码

Sub demo()
    Dim x As Long
    
    For x = 6 To 8
    
        Dim r As Range
        Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
        Debug.Print r.Address, MyIsEmpty(r)
   
    Next x
End Sub

我有一个检查空范围的函数

Public Function MyIsEmpty(rng As Range) As Boolean
    MyIsEmpty = WorksheetFunction.CountA(rng) = 0
End Function

我使用它是因为单元格可能“看起来”是空的，但实际上包含一个公式。

请注意，我已经明确说明了我想要来自哪个 sheet 的单元格 - 用户习惯于点击您认为应该点击的地方以外的地方！ :笑:

OP评论后编辑：

例如你的函数可能看起来像这样

Sub CopyPasteRow()
    Dim lr As Long
    Dim x As Long
    Dim a As Long
    Dim r As Range, r2 As Range
    
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    
    For x = 6 To lr
        
        a = 0
    
        'check columns A to M for this row are empty
        Set r = Sheets(1).Range("A" & CStr(x) & ":M" & CStr(x))
        If Not MyIsEmpty(r) Then
            a = a + 1
        End If
        
        If a = 0 Then
            'check columns N to R for this row are empty
            Set r2 = Sheets(1).Range("N" & CStr(x) & ":R" & CStr(x))
            If Not MyIsEmpty(r2) Then
                a = a + 1
            End If
        Else
            a = 0
        End If
        
        If a <> 0 Then
            'copy the data into columns A to M
            'You might have to adjust the ranges here
            r.Value = r2.Value
        End If
    
    Next x

End Sub

你有一个源范围和一个目标范围 - 你似乎把值放在前一行所以我的值 r 在这个例子中可能是错误的 - 你可以使用 r.Offset(-1,0).Value = r2.Value 我也不确定你想用变量做什么 a 如果那是一个“标志”那么考虑使用布尔值 - 它只有值 True 或 False

如果特定范围为空而另一个不为空，则复制-粘贴到行的范围上方 (VBA)

Copy- Paste above row's Range if a specific range is empty and another is not (VBA)

excel

vba

excel-2019