Блог

У меня есть рабочий лист с данными, и в нем находятся мои два ключевых столбца, идентифицирующих «адрес» (уникальные значения) и «имя» (каждому имени присвоено несколько адресов).).

Каждому имени присваивается свой собственный лист, который постоянно редактируется, и вся информация собирается в master в конце.

Что мне нужно сделать: скопируйте и вставьте адреса, присвоенные имени каждого листа, если этого адреса нет на этом листе, внизу.

Что я пробовал:

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" amp; 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
  

Попробуйте это…

     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('" amp; NameOfSheetValue amp; "'!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" amp; 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