仅当在另一个工作表中找不到匹配项时，VBA 才能复制一系列单元格

Question

仅当新工作表中不存在该行时，才尝试将以下变量范围内的数据复制到新工作表中。

我正在使用辅助列，因为只有在未找到两列中的条件时才应复制单元格。

（场景计算表）

（场景仪表盘）

如果代码实际有效，则预期输出：

仅添加了 3.1 & Apple 和 4.2 & Lemon 行。 重复的 1.2 & Lemon 没有额外的行。

我有这个，但它似乎无休止地运行，没有任何东西被复制。 调试过程似乎结束了，但那是在按住 F8 之后......

Sub CopyToDash()

    Dim main As Worksheet
    Set main = Worksheets("Scenario Calc Table")

    Dim log As Worksheet
    Set log = ThisWorkbook.Worksheets("Scenario Dash")

    Dim searchRange As Range
    Set searchRange = log.Range("R2:R10") 'Helper Column

    Dim RowCount As Integer
    For RowCount = 1 To main.Range("M2:M10").Rows.Count
        Dim lookFor As String
        lookFor = main.Range("M2").Offset(RowCount - 1, 0).Value2 'Uses helper cells

        Dim dupe As Range
        Set dupe = searchRange.Find(lookFor, LookIn:=xlValues)


        Dim copyInfo As Range
        Set copyInfo = searchRange.Range("K2:L40").Offset(RowCount - 1, 0)

        Dim destination As Range
        If dupe Is Nothing Then
            Set destination = log.Range("O" & Rows.Count).End(xlUp).Offset(1)
        Else
            Set destination = dupe
        End If

        destination.Resize(ColumnSize:=copyInfo.Columns.Count).Value2 = copyInfo.Value2
    Next
    
   log.Activate

End Sub

提前致谢 ：）

Answer 1

Sub test()
  Dim c_sh1 As Range
  Dim c_sh2 As Range
  Dim count As Integer
  
  For Each c_sh1 In Range("B1", Range("b1").End(xlDown))
  count = 0
    For Each c_sh2 In Sheets("Sheet2").Range("B1", Sheets("sheet2").Range("B1").End(xlDown))
      If c_sh1 & c_sh1.Offset(0, -1) = c_sh2 & c_sh2.Offset(0, -1) Then
        count = count + 1
      End If
    Next c_sh2
      If count = 0 Then
        Sheets("Sheet2").Range("B1").End(xlDown).Offset(1, 0) = c_sh1
        Sheets("Sheet2").Range("A1").End(xlDown).Offset(1, 0) = c_sh1.Offset(0, -1)
      End If
  Next c_sh1
  
End Sub

可能有更简单的方法，但如果我明白你在尝试什么，那么它应该可以工作。 下面有链接你可以检查excel文件。

https://docs.google.com/spreadsheets/d/16rMzQ-VLx6jq7tQSby0Kq4od02OYfAMr/edit?usp=sharing&ouid=116818902823034098520&rtpof=true&sd=true

Answer 2

我将您的范围转换为表格，因为它更具动态性。

我创建了一个新的辅助列“ Helper Match ”，如图所示并插入了公式

=IFERROR(MATCH([@[Helper Col]];tbDash4[Helper Col];0);"NO MATCH")

我认为评论很容易理解。 希望你喜欢！

Sub CopyToDash()
    ' Worksheets
    Dim wsCalc As Worksheet: Set wsCalc = Sheets("Scenario Calc Table")
    Dim wsDash As Worksheet: Set wsDash = Sheets("Scenario Dash")
    
    ' Tables
    Dim olCalc As ListObject: Set olCalc = wsCalc.ListObjects("tbCalc")
    Dim olDash As ListObject: Set olDash = wsDash.ListObjects("tbDash")

    ' Clear table filters
    If olCalc.AutoFilter.FilterMode Then olCalc.AutoFilter.ShowAllData
    If olDash.AutoFilter.FilterMode Then olDash.AutoFilter.ShowAllData
    
    ' Filter table
    Dim olCol As Long: olCol = olCalc.ListColumns("Helper Match").Index
    olCalc.Range.AutoFilter Field:=olCol, Criteria1:="NO MATCH"

    ' Check for visible rows
    Dim visibleRows As Long
    If olCalc.ListRows.Count > 0 Then
        On Error GoTo errNoRowsToBeCopied
        visibleRows = olCalc.ListColumns(1).DataBodyRange.SpecialCells(xlCellTypeVisible).Count
    End If
    
    ' Set source and destinagion ranges
    Dim srcRng As Range: Set srcRng = olCalc.DataBodyRange.Resize(, 2).SpecialCells(xlCellTypeVisible)
    Dim dstRng As Range: Set dstRng = olDash.HeaderRowRange(olDash.Range.Rows.Count + 1, 1)
    
    ' Copy from Calc to Dash
    srcRng.Copy
    dstRng.PasteSpecial (xlPasteValues)
    
    Application.CutCopyMode = False
    
    Exit Sub
    
errNoRowsToBeCopied:
    Debug.Print "No Rows To Be Copied To Dashboard"
End Sub

Answer 3

您的代码所需的更正是

'Set copyInfo = searchRange.Range("K2:L40").Offset(RowCount - 1, 0)
Set copyInfo = main.Range("K2:L2").Offset(RowCount - 1, 0)

 'destination.Resize(ColumnSize:=copyInfo.Columns.Count).Value2 = copyInfo.Value2
 destination.Resize(1,ColumnSize:=copyInfo.Columns.Count).Value2 = copyInfo.Value2

'Set destination = dupe
Set destination = dupe.offset(0,-3)

或使用匹配

Option Explicit
Sub CopyToDash1()

    Dim main As Worksheet, log As Worksheet
    Dim ar, v, lastrow As Long
    Dim r As Long, rLog As Long, n As Long
    
    With ThisWorkbook
        Set main = .Sheets("Scenario Calc Table")
        Set log = .Sheets("Scenario Dash")
    End With
    
    With log
        rLog = .Cells(.Rows.Count, "R").End(xlUp).Row ' helper
        ar = .Range("R2:R" & rLog)
    End With
        
    With main
        lastrow = .Cells(.Rows.Count, "M").End(xlUp).Row ' helper
        For r = 2 To lastrow
            v = Application.Match(.Cells(r, "M"), ar, 0)
            If IsError(v) Then ' not found
                rLog = rLog + 1
                log.Cells(rLog, "O") = .Cells(r, "K")
                log.Cells(rLog, "P") = .Cells(r, "L")
                log.Cells(rLog, "R") = .Cells(r, "M")
                n = n + 1
                ar = log.Range("R2:R" & rLog)
            End If
        Next
    End With
    
    MsgBox n & " rows added"

End Sub