vba - 更改代码，使其不会填充更多单元格，只需替换为更改

Question

我用来根据主列表中 D 列中的内容填充工作表的代码。每次我运行代码时，它都会重新添加单元格，而不仅仅是更新以反射(reflect)主列表。我很难描述这一点，所以我举个例子。

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
Coubourn, Stephen|A|201|Q4hours
Eudy, Donna      |A|202|Q4hours
Potts, Betty     |A|203|Q4hours

如何防止它翻倍？我只是想让它反射(reflect)它在主表上的内容。下面是我正在使用的代码。

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

请参阅我在下面编辑的代码的相关部分(解释在代码注释中):

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