VBA identified Tables to compare values and skip if match

D

DThib

Active Member
Joined
Mar 19, 2010
Messages
464
Office Version
  1. 365
Platform
  1. Windows
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:
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
 
Last edited:
Sort by date Sort by votes
Hi No Spark,
The workbook we were discussing.

I have data being added to the 2 worksheets (MB51_Draw) and COOIS_Draw) as part of this workbook.
The Userform Add button. Starts running through code and gives me 23 results in the QA_Table.
The remaining results that also meet the 2 criteria are not being pulled.

This may be because the COOIS_Draw sheet will have the Batch ID once. The MB51_Draw sheet will have the matching ID several times and not in the next row down. I think the macro as written is finding the first instance and then not looking further down to the matching Id that will also fulfill the second criteria( column,row for number starting with 5). I am not getting the expected results from a workbook that is going to have information added to the 2 worksheets (MB51_Draw) and COOIS_Draw) that will need to evaluate all entries.
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
I have removed the second criteria and I get the first result for each but not the row that should also contain a column for the 500000000 number
 
Upvote 0
You're right, I didn't consider the necessity of looking further down the column once the first instance was found.
Give this a try
Code: 
Sub Newt()
'revision 3 July 26, 2019 1:39 PM PDT
    Dim Coos As Worksheet, MBs As Worksheet, QAWs As Worksheet
    Dim COr As Range, MBr As Range
    Dim cel As Range, fndRng As Range, firstAddress As String
    Dim tbL As ListObject, oNewRow As ListRow


'set the worksheets
    Set MBs = ThisWorkbook.Sheets("MB51_Draw")
    Set Coos = ThisWorkbook.Sheets("COOIS_Draw")
    Set QAWs = ThisWorkbook.Sheets("QA_Data")


'set ranges and table
    With Coos
       Set COr = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
    End With
    
    With MBs
        Set MBr = .Range("M:M")
    End With
        
    With QAWs
       Set tbL = .ListObjects(1)    'first table on sheet
    End With
    
Application.ScreenUpdating = False


'check if value in COr (order) exists in MBr (batch)
For Each cel In COr
    Set fndRng = MBr.Find(What:=cel.Value, LookIn:=xlValues, LookAt:=xlWhole, _
                          SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
        
    If Not fndRng Is Nothing Then   'meaning it was found
        firstAddress = fndRng.Address
        Do
            'look back into MB51_Draw to (Material Document) for a number starting with 5
            If Left(fndRng.Offset(, -1).Value, 1) = 5 Then
                'check if already in table tbL
                With tbL
                    If WorksheetFunction.CountIf(.ListColumns(3).DataBodyRange, cel.Value) = 0 Then
                        'not found so add to the table
                        Set oNewRow = .ListRows.Add
                        With oNewRow.Range
                            .Cells(1, 1) = cel.Offset(, 3).Value            'Coos.Cells(m, 4).Value
                            .Cells(1, 2) = cel.Offset(, 4).Value            'Coos.Cells(m, 5).Value
                            .Cells(1, 6) = cel.Offset(, 12).Value           'Coos.Cells(m, 13).Value
                            .Cells(1, 3) = fndRng.Value                     'MBs.Cells(g, 13).Value
                            .Cells(1, 4) = fndRng.Offset(, 4).Value         'MBs.Cells(g, 17).Value
                            .Cells(1, 5) = fndRng.Offset(, 1).Value         'MBs.Cells(g, 14).Value
                        End With
                    End If
                End With
            End If
            'look further down the column
            Set fndRng = MBr.FindNext(fndRng)
        Loop While Not fndRng Is Nothing And fndRng.Address <> firstAddress
    End If
Next cel
    
Application.ScreenUpdating = True


MsgBox "The data has been evaluated", vbInformation + vbOKOnly, "QA Sterilized Package Movement"
   
End Sub
 
Upvote 0
Thank you, that worked!


I appreciate your help, greatly!

DThb
 
Upvote 0
Now another wrinkle,
The data may be pulled more than once a day.
The user wants to limit the data place with the macro above by having it only take data for today and place in the worksheet, but make sure they do not pull data twice if the batch number already in the list for today.
Code to this point is below, I have tried adapting the solution you gave with no luck.

Code: 
Private Sub Move_CB_Click()


  Dim RPWs, QAWs As Worksheet
  Dim FirstW As Long
  Dim SecondW As Long
  Dim j, k As Long
  Dim CKDate As Date
  Dim RPr, cel As Range
    
    ON_Open.Hide
    CKDate = Sheets("Released Product").Range("K2").Value
    
   Set QAWs = Sheets("QA_Data")
   With QAWs
     Set QAr = .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
   End With
   Set RPWs = Sheets("Released Product")
   With RPWs
     Set RPr = .Range("D:D")
   End With
    SecondW = Sheets("QA_Data").Cells(Rows.Count, "B").End(xlUp).Row
    FirstW = Sheets("Released Product").Cells(Rows.Count, "B").End(xlUp).Row
    
   For Each cel In RPr
    Set fndRng = QAr.Find(What:=cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                              SearchDirection:=xlNext, MatchCase:=False)
     If Not fndRng Is Nothing Then
        firstAddress = fndRng.Address
        Do
            k = 1 + SecondW
            j = FirstW
             For k = 1 To SecondW
               If QAWs.Cells(k, 10) = CKDate And QAWs.Cells(k, 8) = 2 Then
                   Sheets("Released Product").Cells(j, 1) = CKDate
                   Sheets("Released Product").Cells(j, 2) = QAWs.Cells(k, 1).Value
                   Sheets("Released Product").Cells(j, 3) = QAWs.Cells(k, 2).Value
                   Sheets("Released Product").Cells(j, 4) = QAWs.Cells(k, 3).Value
                   Sheets("Released Product").Cells(j, 5) = QAWs.Cells(k, 4).Value
                   Sheets("Released Product").Cells(j, 6) = QAWs.Cells(k, 5).Value
                   Sheets("Released Product").Cells(j, 7) = QAWs.Cells(k, 6).Value
                  j = j + 1
               End If
             Next k
            Set fndRng = RPr.FindNext(fndRng)
        Loop While Not fndRng Is Nothing And fndRng.Address <> firstAddress
     End If
   Next cel
    MsgBox "The data has been moved", vbInformation + vbOKOnly, "QA Sterilized Package       Movement"
         
End Sub
Help?!
 
Upvote 0
To better explain, hopefully, the data from the worksheet will be processed and those results will be parsed by this macro.
The macro uses these criteria to define the results to be added to the "Released Product" worksheet. The data may get pulled more than once a day.
If the data is run again, I need to make sure the data already analyzed and copied is not recopied but rather skipped. I have spent 2 days trying to figure out how to finesse this.

No luck,

DThib
 
Upvote 0
Sorry, you've lost me again.

The file you supplied doesn't have a "Released Product" sheet
and don't know what constitutes 'list for today'.

If the data is run again, I need to make sure the data already analyzed and copied is not recopied but rather skipped. I have spent 2 days trying to figure out how to finesse this.
Click to expand...
by chance does (manually) using Excels built in Remove Duplicates function on the Table Tools ribbon produce what you're after ?
 
Upvote 0
In the file (Sheets("Released Product") is in the file.
In any event,

the worksheet(""Released Product") is the landing page for the macro.
The workbook uses worksheet("QA_Data") to provide the data from your first code help.
The user confirms all information is complete by adding a "c" to a column. This generates a conditional response that gives a 2 in another column and turns the row green.

The code drops the information from the current date and the number 2 appearing into the worksheet(""Released Product").

I'll highlight the code for you.

Code: 
Private Sub Move_CB_Click()


  Dim RPWs, QAWs As Worksheet
  Dim FirstW As Long
  Dim SecondW As Long
  Dim j, k As Long
  Dim CKDate As Date
  Dim RPr, cel As Range
    
    ON_Open.Hide
    CKDate = [B][COLOR=#b22222]Sheets("Released Product")[/COLOR][/B].Range("K2").Value
    
   Set QAWs = Sheets("QA_Data")
   With QAWs
     Set QAr = .Range("C2", .Range("C" & .Rows.Count).End(xlUp))
   End With
   Set RPWs = [COLOR=#b22222][B]Sheets("Released Product")[/B][/COLOR]
   With RPWs
     Set RPr = .Range("D:D")
   End With
    SecondW = Sheets("QA_Data").Cells(Rows.Count, "B").End(xlUp).Row
    FirstW = [B][COLOR=#b22222]Sheets("Released Product")[/COLOR][/B].Cells(Rows.Count, "B").End(xlUp).Row
    
   For Each cel In RPr
    Set fndRng = QAr.Find(What:=cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                              SearchDirection:=xlNext, MatchCase:=False)
     If Not fndRng Is Nothing Then
        firstAddress = fndRng.Address
        Do
            k = 1 + SecondW
            j = FirstW
             For k = 1 To SecondW
               If QAWs.Cells(k, 10) = CKDate And QAWs.Cells(k, 8) = 2 Then
                  [COLOR=#b22222][B] Sheets("Released Product")[/B][/COLOR].Cells(j, 1) = CKDate
                   [COLOR=#b22222][B]Sheets("Released Product")[/B][/COLOR].Cells(j, 2) = QAWs.Cells(k, 1).Value
                   [B][COLOR=#b22222]Sheets("Released Product")[/COLOR][/B].Cells(j, 3) = QAWs.Cells(k, 2).Value
                   [B][COLOR=#b22222]Sheets("Released Product")[/COLOR][/B].Cells(j, 4) = QAWs.Cells(k, 3).Value
                   [B][COLOR=#b22222]Sheets("Released Product")[/COLOR][/B].Cells(j, 5) = QAWs.Cells(k, 4).Value
                   [B][COLOR=#b22222]Sheets("Released Product")[/COLOR][/B].Cells(j, 6) = QAWs.Cells(k, 5).Value
                   [B][COLOR=#b22222]Sheets("Released Product")[/COLOR][/B].Cells(j, 7) = QAWs.Cells(k, 6).Value
                  j = j + 1
               End If
             Next k
            Set fndRng = RPr.FindNext(fndRng)
        Loop While Not fndRng Is Nothing And fndRng.Address <> firstAddress
     End If
   Next cel
    MsgBox "The data has been moved", vbInformation + vbOKOnly, "QA Sterilized Package       Movement"
         
End Sub

All sheet references to released product highlighted in red.

DThib
 
Upvote 0
So that we're both dealing with the same thing,
will you please download the file you link to in post 13 and let me know where to find
Sheets("Released Product") and what you are referring to as the list for today.


Thanks
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Could not set the RowSource property. Invalid property value. Error 380
2
Replies
16
Views
210
RoryA
RoryA
B
  • Question Question
Matching Multiple Header Row Cell Values - Copy the data below to next available row.
Replies
2
Views
565
B-radK
B
Drrellik
  • Solved
VBA to complete Index/Match with 2 criteria
2
Replies
10
Views
423
Alex Blakenburg
A
M
  • Question Question
VBA Code - Run Code if cell value is not blank
Replies
0
Views
624
MHamid
M
D
  • Solved
Excel 365 VBA module Identify value in first column of Table
Replies
5
Views
457
Joe4
Joe4

Forum statistics

Threads
1,223,910
Messages
6,175,316
Members
452,634
Latest member
cpostell

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top