復制 - 如果特定范圍為空而另一個不是（VBA），則粘貼在行范圍上方

Question

早上好家伙！

總結問題

所以我在這里無法完善和優化代碼。 我是新手，但我很確定這可以做得更好。

所以我在活動工作表中有一個表格。 我想做的是：

1. 掃描第 6 行的 Columns(A:M) 以查看所有單元格是否為空
2. 如果是，則掃描第 6 行的列 (N:R) 以查看所有單元格是否為空
3. 如果 2. 為假，則在第 6 行復制上述行的列 (A:I)
4. 重復 1-3，但在第 7 行

這個過程應該重復，直到表格的行結束。 我可能想要合並的是ActiveSheet.ListObjects(1).Name或類似的東西，這樣我就可以復制工作表而無需調整代碼。

描述你嘗試過的東西

我已經嘗試了幾個嘗試執行這個概念的潛艇。 我還沒有想出的是，我怎樣才能讓它盡可能高效和盡可能無風險。 我的代碼有效（我不完全確定它是否有任何問題）但它真的太多了。

我在下面發布以下代碼。 如果它太基本，請原諒我。 我是 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

與其查看單個單元格，不如查看 Ranges。 考慮這段代碼

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

我使用它是因為單元格可能“看起來”是空的，但實際上包含一個公式。

請注意，我已經明確說明了我希望 Cells 來自哪個工作表 - 用戶習慣於單擊您認為應該在的地方以外的地方！ ：笑：

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做什么