如果尚未在工作表中，则将粘贴复制到新工作表中

Question

我有一个数据供应工作表，其中是我的两个关键标识列“地址”（唯一值）和“名称”（每个名称都有多个分配的地址）。

每个名称都分配有自己的工作表，该工作表会不断进行编辑，最后将所有信息收集在一个主文件中。

我需要做的： 复制并粘贴地址，如果该地址不在该工作表中，则分配给每个工作表的名称，位于底部。

我尝试过的事情：

1. 无法清除工作表内容并粘贴到信息中，因为更新的信息会丢失。
2. 将名称与工作表名称匹配并粘贴到完整的行上，但这只是添加到底部。粘贴不仅匹配新行的所有值。
3. 查询以添加新地址 - 刷新查询时会出现问题，因为所有信息都被覆盖并且更新的信息现在不再与地址匹配。

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

试试这个...

    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