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

Question

Attempting to copy the data in the below variable range into a new worksheet only if the row doesn't already exist in the new worksheet.

I'm using helper columns as the cells should only be copied if the criteria in both columns aren't found.

(Scenario Calc Table Sheet)

(Scenario Dash Sheet)

Expected output if code actually works:

Just the rows 3.1 & Apple and 4.2 & Lemon have been added. There is no additional row for the duplicate 1.2 & Lemon.

I've got this, but it just seems to run endlessly with nothing being copied. Going through in debug seems to get to an end, but that's after holding F8 down...

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

Thanks in advance :)

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

probably there is much simpler way but if I understand what your are trying then It should work. there is link below you can check excel file.

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

Answer 2

I transformed your ranges into tables because it's more dynamic.

I created a new helper column ' Helper Match ' as in picture and inserted the formula

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

I think the comments are easy to understand. Hope you like it!

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

The corrections required to your code are

'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)

or use Match

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