コードを変更して、より多くのセルを取り込み、変更を置き換えます。

Question

このコードは、マスターリストの列Dに基づいてシートを作成するために使用しています。コードを実行するたびに、マスターリストを反映するためだけに更新するのではなく、セルが追加されます。私はこれを説明するのが苦労しているので、私は例を挙げます。

Coubourn, Stephen|A|201|Q4hours  
Eudy, Donna  |A|202|Q4hours 
Potts, Betty  |A|203|Q4hours 

これらは、マスターシートに記載されているものに基づいて、シートに入力する必要がある唯一のものです。しかし、別のコードを実行すると、次のように2倍になります。

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