Question

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

每个名称都分配有自己的工作表，该工作表将不断编辑，最后将所有信息收集在母版中。

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

我尝试过的事情：

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

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

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

1 个答案: