Myujth

I have found this code on this site from a previously answered question from two years ago.
The code looks at the rows of data on a Master Sheet and copies the relevant rows based on column D (Project) to the named sheet.

If a named sheet does not exist, a comment box is added to Column D, stating that the sheet name does not exist.

The code also looks at Column A (Invoice) and uses this a a unique ID so duplicate rows are not copied to the named sheets.

I amended the code to suit my needs (sheet titles, etc) but when I run the code, the relevant row is NOT copied to the named sheet but to the next sheet to the right.

I can't work out what is wrong with the code. Hoping someone can help!!!

Column A Column B Column C Column D
Invoice Date Amount Project
I18-1234 1/10/2018 $125.00 Project 1
I18-5678 10/10/2018 $1,500.00 Project 2
I18-2468 20/10/2018 $10,000.00 Project 1
I18-7931 15/10/2018 $300.00 Project 3
I18-1010 24/10/2018 $1,000.00 Project 1

I have a main sheet named "Master Sheet". This is where all data is entered.

Currently, I have another sheet named "Project 1".

The other sheets I have are named "Sheet2" and "Sheet3". (This is just while I test the code).

Sub Test()

Dim cell As Range
Dim cmt As Comment
Dim bolFound As Boolean
Dim sheetNames() As String
Dim lngItem As Long, lngLastRow As Long
Dim sht As Worksheet, shtMaster As Worksheet
Dim MatchRow As Variant

'Set master sheet
Set shtMaster = ThisWorkbook.Worksheets("Master Data")

 'Get the names for all other sheets
ReDim sheetNames(0)
For Each sht In ThisWorkbook.Worksheets
 If sht.Name <> shtMaster.Name Then
 sheetNames(UBound(sheetNames)) = sht.Name
 ReDim Preserve sheetNames(UBound(sheetNames) + 1)
 End If
Next sht
ReDim Preserve sheetNames(UBound(sheetNames) - 1)

For Each cell In shtMaster.Range("D2:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row)
bolFound = False

' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
 bolFound = True
 Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))

 ' now use a 2nd Match, to find matches in Unique column "A"
 MatchRow = Application.Match(cell.Offset(, -3).Value, sht.Range("A:A"), 0)
 If Not IsError(MatchRow) Then
 shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(MatchRow, 1)

 Else '<-- no match in sheet, add the record at the end
 On Error GoTo SetFirst
 lngLastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
 On Error GoTo 0
 shtMaster.Rows(cell.Row).EntireRow.Copy Destination:=sht.Cells(lngLastRow, 1)
 End If

End If

If bolFound = False Then
 For Each cmt In shtMaster.Comments
 If cmt.Parent.Address = cell.Address Then cmt.Delete
 Next cmt
 cell.AddComment "no sheet found for this row"
 ActiveSheet.EnableCalculation = False
 ActiveSheet.EnableCalculation = True
End If

Set sht = Nothing
Next
Exit Sub

SetFirst:
 lngLastRow = 1
 Resume Next

End Sub

change your part of the code :

' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
 bolFound = True
 Set sht = ThisWorkbook.Worksheets(sheetNames(Application.Match(cell.Value2, sheetNames, 0)))

to

' instead of looping through the array of sheets >> use Application.Match
If Not IsError(Application.Match(cell.Value2, sheetNames, 0)) Then
 bolFound = True
 Set sht = ThisWorkbook.Worksheets(cell.Value)