Change code so that it doesnt populate more cells,

Question

This code that I'm using to populate sheets based off of what is in Column D in the master list. Every time I run the code it re adds the cells rather than just update to reflect the master list. I'm having a hard time describing this so I'll give an example.

Coubourn, Stephen|A|201|Q4hours    
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours

These are the only ones that should populate the sheet, based off of what is in the Master sheet. However if I run the code another, it will double it to look like this:

Coubourn, Stephen|A|201|Q4hours
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours
Coubourn, Stephen|A|201|Q4hours
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours

How do I prevent it from doubling up? I just want it to reflect what it on the Master sheet. Below is the code I am using.

Sub TestRevised()

    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

    'Set master sheet
    Set shtMaster = ThisWorkbook.Worksheets("Master Vitals 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("D1:D" & shtMaster.Cells(shtMaster.Rows.Count, "D").End(xlUp).Row)
        bolFound = False
        For lngItem = LBound(sheetNames) To UBound(sheetNames)
            If cell.Value2 = sheetNames(lngItem) Then
                bolFound = True
                Set sht = ThisWorkbook.Worksheets(sheetNames(lngItem))
                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
        Next lngItem
        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
    Next

    Exit Sub

    SetFirst:
        lngLastRow = 1
        Resume Next

End Sub

Answer 1

See the relevant part of your code I've edited below (explanation are inside the code comments):

Dim MatchRow As Variant

For Each cell In shtMaster.Range("D1: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