VBA identified Tables to compare values and skip if match

[DThib]

Help!!!

I have a code to look at a result table (QA_Table) column to make sure the results are not duplicated when adding new entries from a worksheet to the table. These two worksheets are in the same workbook.

I had it working and it stopped working. I have been tinkering with it and it just repeats the same results already in the table!

Here is the code:

Sub Newt()


    Dim MBs As Worksheet, Coos As Worksheet, QAws As Worksheet
    Dim MBRow As Long, CoRow As Long, QArow As Long
    Dim m As Long, j As Long, l As Long, g As Long
    Dim x As Long, y As Long, a As Long
    Dim b1 As String
[COLOR=#b22222]    Dim TBL1, TBL2, TabC As Range[/COLOR]


    
    Set MBs = ThisWorkbook.Sheets("MB51_Draw")
    Set Coos = ThisWorkbook.Sheets("COOIS_Draw")
    Set QAws = ThisWorkbook.Sheets("QA_Data")
    
[COLOR=#b22222]    Set tbl = Sheets("QA_Data") '.ListObjects("QA_Table")[/COLOR]
[COLOR=#b22222]    With tbl[/COLOR]
[COLOR=#b22222]      Set TBL1 = .Range("C2", .Range("C1").End(xlDown))[/COLOR]
[COLOR=#b22222]    End With[/COLOR]
[COLOR=#b22222]    Set searchw = Sheets("COOIS_Draw")[/COLOR]
[COLOR=#b22222]    With searchw[/COLOR]
[COLOR=#b22222]       Set TBL2 = .Range("A2", .Range("A1").End(xlDown))[/COLOR]
[COLOR=#b22222]    End With[/COLOR]

[COLOR=#b22222]      For Each TabC In TBL1[/COLOR]
[COLOR=#b22222]         If WorksheetFunction.CountIf(TBL2, TabC) = 0 Then[/COLOR]
[COLOR=#b22222]            tbl.Range("C" & Rows.Count).End(xlUp) = TabC[/COLOR]
            
            MBRow = MBs.Cells(Rows.Count, "B").End(xlUp).Row
            CoRow = Coos.Cells(Rows.Count, "B").End(xlUp).Row
            QArow = QAws.Cells(Rows.Count, "C").End(xlUp).Row
                j = QArow + 1
                g = MBRow
                m = CoRow
                 For m = 1 To CoRow
                  For g = 1 To MBRow
                     If Coos.Cells(m, 1) = MBs.Cells(g, 13).Value And MBs.Cells(g, 12) Like "5*" Then
                            QAws.Cells(j, 1) = Coos.Cells(m, 4).Value
                            QAws.Cells(j, 2) = Coos.Cells(m, 5).Value
                            QAws.Cells(j, 3) = MBs.Cells(g, 13).Value
                            QAws.Cells(j, 4) = MBs.Cells(g, 17).Value
                            QAws.Cells(j, 5) = MBs.Cells(g, 14).Value
                            j = j + 1
                     End If
                  Next g
                 Next m
         End If
      Next
   
End Sub

Trouble Code is in red

Arrrrgh,
DThib

 

[DThib]

NoSpark,

Here it is.
https://app.box.com/s/4prvoi7h2z4p37imwegekfr27bt62c2r

Button document
https://app.box.com/s/y7t4rpxo2fyfr2o65va8wmnzj7x52uep

DThib

 

[NoSparks]

Does this work for you ?

Private Sub Move_CB_Click()
' revision_2 August 3, 2019
    Dim QAWs As Worksheet, QAr As Range, CKDate As Date
    Dim oLo As ListObject, oNewRow As ListRow
    
Application.ScreenUpdating = False

ON_Open.Hide
CKDate = Sheets("Released Product").Range("K2").Value
Set QAWs = Sheets("QA_Data")
Set QAr = QAWs.ListObjects("QA_Table").ListColumns(3).DataBodyRange
Set oLo = Sheets("Released Product").ListObjects("RP_Table")
'add a row if the table has no rows
If oLo.DataBodyRange Is Nothing Then oLo.ListRows.Add

'loop thru QAr
For Each cel In QAr
    'check the date and col H status
    If cel.Offset(, 7) = CKDate And cel.Offset(, 5) = 2 Then
        'check if already in RP_Table
        With oLo
            If WorksheetFunction.CountIfs(.ListColumns(4).DataBodyRange, cel.Value, .ListColumns(1).DataBodyRange, CKDate) = 0 Then
                'need to add to RP_Table
                Set oNewRow = .ListRows.Add
                With oNewRow
                    .Range(1, 1) = CKDate
                    .Range(1, 2).Resize(, 6).Value = QAWs.Cells(cel.Row, 1).Resize(, 6).Value
                End With
            End If
        End With
    End If
Next cel

'remove first table row if it's blank    'uncomment if you want this
'If WorksheetFunction.CountA(oLo.ListRows(1).Range) = 0 Then oLo.ListRows(1).Delete

Sheets("Released Product").Activate

Application.ScreenUpdating = True
    
End Sub

 

[DThib]

Thanks, it worked.

DThib