They keep pulling me back in! 
The sheets now need to parse from a 3rd database draw that is dumped into a worksheet in the workbook.
A match of ZMB will generate > 1 response since ZMB gives Serial numbers to be added to the lot, and that works.
Issue is it takes >25 minutes to run the code.
Anyway to speed this up?
Code is below:
DThib
The sheets now need to parse from a 3rd database draw that is dumped into a worksheet in the workbook.
A match of ZMB will generate > 1 response since ZMB gives Serial numbers to be added to the lot, and that works.
Issue is it takes >25 minutes to run the code.
Anyway to speed this up?
Code is below:
Code:
Sub Newt()
'revision 4 - 25 October 2019 D Thibodeaux
Dim ZMs As Worksheet, Coos As Worksheet, MBs As Worksheet, QAWs As Worksheet
Dim ZMBLBr As Range, COr As Range, MBr As Range
Dim cel As Range, buds As Range, fndRng As Range, firstAddress As String
Dim tbL As ListObject, oNewRow As ListRow
Dim dDate As Date
ON_Open.Hide
Application.ScreenUpdating = False
'set the worksheets
Set MBs = ThisWorkbook.Sheets("MB_Draw")
Set Coos = ThisWorkbook.Sheets("COO_Draw")
Set ZMs = ThisWorkbook.Sheets("ZMB_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 ZMs
Set ZMBLBr = .Range("F:F") 'Batch column
End With
With MBs
Set MBr = .Range("M:M") 'Batch column
End With
With QAWs
Set tbL = .ListObjects(1) 'first table on sheet
End With
dDate = Sheets("QA_Data").Range("Q1").Value
'check if value in COr (order) exists in MBr (batch)
For Each cel In MBr
Set fndRng = COr.Find(what:=cel.Value, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
For Each buds In ZMBLBr
If Not fndRng Is Nothing Then 'meaning it was found
firstAddress = cel.Address
' Do
'look back into MB51_Draw to (Material Document) for a number starting with 5
If Left(cel.Offset(, -1).Value, 1) = 5 Then
'For Each buds In ZMBLBr
If buds = cel.Value And Not buds.Offset(, 1).Value = "" Then
'check if already in table tbL
With tbL
If WorksheetFunction.CountIf(.ListColumns(4).DataBodyRange, cel.Value) = 0 Then
'not found so add to the table
Set oNewRow = .ListRows.Add
With oNewRow.Range
.Cells(1, 11) = dDate
.Cells(1, 1) = cel.Offset(, 3).Value 'Coos.Cells(m, 4).Value Material #
.Cells(1, 2) = cel.Offset(, 4).Value 'Coos.Cells(m, 5).Value Material Description
.Cells(1, 8) = cel.Offset(, 12).Value 'Coos.Cells(m, 13).Value Actual Start Time
.Cells(1, 3) = fndRng.Value 'MBs.Cells(g, 13).Value Batch #
.Cells(1, 4) = buds.Offset(, 1).Value 'ZMs.Cells(k, 13).Value Serial #
.Cells(1, 5) = cel.Offset(, 2).Value 'Coos.Cells(m, 3).Value Order Type
.Cells(1, 6) = fndRng.Offset(, 4).Value 'MBs.Cells(g, 17).Value Entry Date
.Cells(1, 7) = fndRng.Offset(, 1).Value 'MBs.Cells(g, 14).Value Special Purchase Order
End With
End If
End With
End If
' Next buds
End If
'look further down the column
Set fndRng = COr.FindNext(fndRng)
'Loop While Not fndRng Is Nothing And fndRng.Address <> firstAddress
End If
Next buds
Next cel
Application.ScreenUpdating = True
MsgBox "The data has been evaluated", vbInformation + vbOKOnly, "QA Sterilized Package Movement"
ON_Open.Show
End SubDThib
