VBA code that adds a new row from another workbook based on a criteria, checks for duplicates based on a keyword located in a specific column ..

[tcopeland]

I have a master spreadsheet that is broken into several smaller sheets based on a key word in a specific column. I was trying to create a a code that would update the smaller sheets with the new data (see below). My issue is that it pulls in all the data ignoring the keyword criteria. Any help would be appreciated. Thank you.





Sub CopyRows()
Dim wbSource As Workbook
Dim wbTarget As Workbook
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim lastRowSource As Long
Dim lastRowTarget As Long
Dim i As Long
Dim j As Long
Dim copyRow As Boolean
Dim criteriaColumn As Long
Dim keywordColumn As Long
Dim keyword As String

' Set the source and target workbooks and worksheets
Set wbSource = Workbooks("SourceWorkbook.xlsx")
Set wbTarget = ThisWorkbook ' Change this to the target workbook
Set wsSource = wbSource.Worksheets("SourceWorksheet")
Set wsTarget = wbTarget.Worksheets("TargetWorksheet") ' Change this to the target worksheet

' Set the column that contains the criteria to check for duplicates
criteriaColumn = 1 '

' Set the column that contains the keyword to check for duplicates
keywordColumn = 2 '

' Set the keyword to check for duplicates
keyword = "Duplicate" '

' Find the last row in the source and target worksheets
lastRowSource = wsSource.Cells(wsSource.Rows.Count, criteriaColumn).End(xlUp).Row
lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, criteriaColumn).End(xlUp).Row

' Loop through the rows in the source worksheet
For i = 1 To lastRowSource
copyRow = True

' Check if the criteria matches any rows in the target worksheet
For j = 1 To lastRowTarget
If wsSource.Cells(i, criteriaColumn).Value = wsTarget.Cells(j, criteriaColumn).Value And _
wsSource.Cells(i, keywordColumn).Value <> keyword Then
copyRow = False
Exit For
End If
Next j

' If the criteria doesn't match any rows in the target worksheet, copy the row
If copyRow Then
lastRowTarget = lastRowTarget + 1
wsSource.Rows(i).Copy wsTarget.Rows(lastRowTarget)
End If
Next i

' Update any formulas in the new rows to refer to the source workbook
For i = lastRowTarget - (lastRowSource - 1) To lastRowTarget
wsTarget.Rows(i).Replace wbSource.Name, wbTarget.Name, xlPart
Next i
End Sub

 

[rlv01]

If it is ignoring the keyword criteria then I question whether copyRow = False ever executes, Have you set a breakpoint to see?

You should be able to see what is going on by using the debugger to single step through a few rows.