如果工作表中没有，则将粘贴复制到新工作表中

Question

I have a data supply worksheet and in that are my two key identifying columns "address" (unique values) and "name" (each name has multiple assigned addresses).

Each name is assigned its own worksheet which is constantly edited and all information collected in a master at the end.

What I need to do: Copy and paste over addresses, assigned to the name to each worksheet if that address is not in that worksheet, at the bottom.

Things I tried:

1. Clear contents of sheets and paste in info unable to do so as updated information would be lost.
2. Match Name to sheetname and paste over complete rows but this is just added to the bottom. Pasting all values that match not only new rows.
3. Query to add new addresses - Issues arise when query is refreshed as all information is just overwritten and updated information now doesn't match with address any more.

Sub new_cases()

    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 shtmaster = ThisWorkbook.Worksheets("data_supply")

    'collect 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("P2:P" & shtmaster.Cells(shtmaster.Rows.Count, "P").End(xlUp).Row)
        bolFound = False
        If Not IsError(Application.Match(cell.Value2, sheetnames, 0)) Then
            bolFound = True
            Set sht = ThisWorkbook.Worksheets(sheetnames(Application.Match(cell.Value2, sheetnames, 0)))

            ' Tried finding a way to do unique match for column E 
            
            MatchRow = Application.Match(?????????)
            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

Answer 1

Try this...

    Private Sub CommandButton1_Click()
    
    'VBA Copy paste into new worksheet if not already in sheet
    
    'All worksheets have headers
    'Source (data_supply) worksheet has 3 columns: Column A header = Names, Column B header = Addresses, Column C header = Comments
    'Target (names) worksheets have 1 column: Column A header = Addresses
    'Adapt code to suite your columns
    
    Dim SourceLastRow As Long
        SourceLastRow = Sheets("data_supply").Cells(Sheets("data_supply").Rows.Count, "A").End(xlUp).Row  'Find source last row
    
    If SourceLastRow = 1 Then Exit Sub ' if the last row is the header row then exit
    
    Dim NameOfSheetValue As String
    Dim SourceAddressValue As String
    Dim TargetAddressValue As Long
    Dim TargetLastRow As Long
    Dim WorksheetExists As Boolean
    Dim RowCopied As Variant
    Dim i As Long
    
    For i = 2 To SourceLastRow 'Start at 2 to allow for headers and loop through source row values
    
        'for each row in loop, check if corresponding worksheet exists
        NameOfSheetValue = Sheets("data_supply").Cells(i, 1).Value
        WorksheetExists = Evaluate("ISREF('" & NameOfSheetValue & "'!A1)") 'code permits sheet names to have spaces
    
        If WorksheetExists = True Then

                With Sheets("data_supply")
               
                 SourceAddressValue = .Cells(i, 2).Value 'assign address value from column B to variable                          
                    RowCopied = .Range(.Cells(i, 1), .Cells(i, 3)).Value 'assign row i from column 1 to 3 to variable RowCopied
    
                End With
    
                With Sheets(NameOfSheetValue)
                
                 TargetLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 'find the last row and assign to variable
                      TargetAddressValue = WorksheetFunction.CountIf(.Range("B2:B" & TargetLastRow), SourceAddressValue) 'see if source address exists in target address
    
                     If TargetAddressValue = 0 Then 'if = 0 then it doesn't exist therefore add source address to target address
    
                       '.Cells(TargetLastRow + 1, 1).Value = SourceAddressValue 'add new address to last row value  + 1
                       .Range(.Cells(TargetLastRow + 1, 1), .Cells(TargetLastRow + 1, 3)).Value = RowCopied
                
                     End If
                
                End With
                
               'Delete comment in column C: "No sheet found for this row."
               Sheets("data_supply").Cells(i, 3).Value = Null
                
            Else
                
            'Add comment in column C: "No sheet found for this row"
             Sheets("data_supply").Cells(i, 3).Value = "No sheet found for this row."
             
        End If
    
    Next i
    
    End Sub