更改代码，以便它不会填充更多单元格，只会替换更改

Question

此代码用于基于主列表中列D中的内容填充表单。每次运行代码时，都会添加单元格，而不仅仅是更新以反映主列表。我很难描述这个，所以我举个例子。

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 

如何防止它倍增？我只是想让它反映在主表上。以下是我正在使用的代码。

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