VBA identified Tables to compare values and skip if match

DThib

Active Member
Joined
Mar 19, 2010
Messages
427
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.
 

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

DThib

Active Member
Joined
Mar 19, 2010
Messages
427
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
 

NoSparks

Well-known Member
Joined
Mar 15, 2013
Messages
958
Office Version
2010
Platform
Windows
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
 

DThib

Active Member
Joined
Mar 19, 2010
Messages
427
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?!
 

DThib

Active Member
Joined
Mar 19, 2010
Messages
427
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
 

NoSparks

Well-known Member
Joined
Mar 15, 2013
Messages
958
Office Version
2010
Platform
Windows
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.
by chance does (manually) using Excels built in Remove Duplicates function on the Table Tools ribbon produce what you're after ?
 

DThib

Active Member
Joined
Mar 19, 2010
Messages
427
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
 

NoSparks

Well-known Member
Joined
Mar 15, 2013
Messages
958
Office Version
2010
Platform
Windows
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
 

Subscribe on YouTube

Watch MrExcel Video

Forum statistics

Threads
1,105,925
Messages
5,508,146
Members
408,667
Latest member
jh89

This Week's Hot Topics

Top