VBA，如果ColA中的所有行都已填充且ColB為空白（反之亦然），則將這些行復制到新作業表

我正在嘗試合并以下邏輯，如果 Col A 中的所有行都已填充且 Col B 為空白（反之亦然），則將這些行復制到新作業表中。

這是我到目前為止所擁有的：

Sub DataValidation()

    Dim rng As Range
    Dim cell As Range

    Set rng = Range("A:B")

    For Each cell In rng
        
    If Cel.Value = "" Then
    Sheets("List").Cel.Value.EntireRow.Copy Destination:=Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
        
    Next cell
    
End Sub

有人能幫忙嗎？我需要 1) 方面的幫助If.Cel.Value=""，我認為這不能確定 Col A 填充和 Col B 為空白的邏輯。2) 我需要幫助識別這些行并復制到新選項卡。

最新代碼：

Sub DataValidationTwo()
    Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long

    Set ws = ActiveSheet
    lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing

    For i = 4 To UBound(arr) '4 supposing that headers exist on the third row
        If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
            addToRange rngCopy, ws.Range("A" & i)
        End If
    Next i
        
   If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
         Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
         
    MsgBox "Complete"
End Sub

新代碼。它只是粘貼第 4 行進行測驗。它應該粘貼更多我的測驗行。

Sub DataValidationTwo()
    Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long
    
    With Sheets("test")
    .Rows(2 & ":" & .Rows.Count).Delete
    End With
    
    Set ws = ActiveSheet
    'Set ws = Sheets("ATP List")
    lastR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing

    For i = 4 To UBound(arr) '4 supposing that headers exist on the third row
        If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
            addToRange rngCopy, ws.Range("A" & i)
        End If
        

    Next i
        
   If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
         Sheets("test").Range("A" & Rows.Count).End(xlUp).Offset(1)
         
         
    MsgBox "Complete"
End Sub

uj5u.com熱心網友回復：

首先，你的參考cell.value有一個錯字，它需要是cell.value

至于解決方案，就像 Bigben 說的，aRange.AutoFilter可能是這里沒有 Advanced Filters 的最簡單的選項。

你會尋找這樣的東西

rng.AutoFilter Field:=1, Criteria1:="<>" 'This will filter by non-blanks in Column 1

rng.AutoFilter Field:=2, Criteria1:="=" 'This will filter by blanks in Column 2

當一個范圍被過濾時，如果你使用 rng，它仍然會參考整個范圍，包括那些隱藏的（基本上忽略過濾器）。這就是您現在應該使用 rng.specialCells(xlCellTypeVisible) 來參考顯示范圍的原因。

混合和匹配過濾器，然后使用rng.specialCells(xlCellTypeVisible).Copy

uj5u.com熱心網友回復：

請嘗試下一個方法。它使用一個陣列并構建一個Union范圍，以便在代碼端復制。這就是為什么 is 應該比在所有單元格之間迭代并一次復制一行要快得多：

Sub DataValidation()
    Dim ws As Worksheet, lastR As Long, arr, rngCopy As Range, i As Long

    Set ws = ActiveSheet
    lastR = ws.Range("A" & ws.rows.count).End(xlUp).row
    arr = ws.Range("AU4:AV" & lastR).Value2 'place the range in an array for faster iteration/processing

    For i = 2 To UBound(arr) '2 supposing that headers exist on the first row
        If (arr(i, 1) <> "" And arr(i, 2) = "") Or (arr(i, 2) <> "" And arr(i, 1) = "") Then
            addToRange rngCopy, ws.Range("A" & i)
        End If
    Next i
        
   If Not rngCopy Is Nothing Then rngCopy.EntireRow.Copy _
         Sheets("test").Range("A" & rows.count).End(xlUp).Offset(1)
End Sub

Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub

標籤：擅长vba

上一篇：ExcelVBA查找結果不一致

下一篇：Openpyxl-復制和粘貼資料時添加的空單元格