更改代码，以便它不填充更多的单元格，只是取代更改
我正在使用这个代码来填充基于主列表中的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
请参阅下面我编辑的代码的相关部分（解释在代码注释中）：
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