VBA 追加されたデータのみ転記

VBAでデータの転記を行いたいです

具体的には
・元データと、転機先のブックが分かれている
・転記先では業者ごとにシートを作成
シートが既存⇒そのシートにデータを転記
シートがない⇒シートを作成しそこにデータを転記
・元データ数は最終的に6000を超える
★元データはどんどん追加されていく

★印のためにコードが書けずにいます
追加されたデータだけを転記したいのですが、すでに転記済みのデータも上積みされていっていしまいます。
これを解決する方法はありますでしょうか。


Sub test()

'定義枠-------------------------------------------------------------------------------------------
    
    Dim ws As Worksheet, flg As Boolean
    Dim name As String, 業者名 As String, 業者 As String
    Dim ws1 As Object, ws3 As Object, ws2 As Object
    Dim wb As Workbook, motowb As Workbook, book1 As Workbook
    Set motowb = ActiveWorkbook
    Set wb = ThisWorkbook
    Set book1 = Workbooks("加工後.xlsm")
    Set ws1 = wb.Worksheets(1)
    Set ws3 = wb.Worksheets(2)
    Set ws2 = wb.Worksheets(3)
    Dim mrow As Integer, row As Integer, row2 As Integer
    mrow = ws1.Cells(Rows.Count, 1).End(xlUp).row
    Dim i As Long
    Dim Worksheet As Worksheet
    
  '-----------------------------------------------------------------------------------------------

    Workbooks.Open ThisWorkbook.Path & "\加工前データ.xlsm"
    Set motowb = ActiveWorkbook
    mrow = motowb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).row
    
    
    With ws1.Range(ws1.Cells(9, 1), ws1.Cells(mrow, 12))
        .Value = Worksheets(1).Range(Worksheets(1).Cells(9, 1), Worksheets(1).Cells(mrow, 12)).Value
        .RowHeight = 23.25
    End With
    
    

    For i = 9 To mrow
    業者名 = ws1.Cells(i, 5)
    
        flg = False

        For Each ws In book1.Worksheets
            
            If ws.name = 業者名 Then
            flg = True
            End If
            Next ws
    
    If flg = True Then
        On Error GoTo myError
            book1.Worksheets(業者名).Activate
            Set ws = wb.Worksheets(業者名)
            row = ws.Cells(Rows.Count, 1).End(xlUp).row
            ws.Range(ws.Cells(row + 1, 1), ws.Cells(row + 1, 12)).Value = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 12)).Value
            ws.Cells(row + 2, 9).Value = "回数"
            ws.Cells(row + 2, 10).Formula = "=SUM(J9:J" & (row + 1) & " )"
            ws.Cells(row + 2, 11).Value = "合計"
            ws.Cells(row + 2, 12).Formula = "=SUM(L9:L" & (row + 1) & " )"

    Else

myError:
            wb.Sheets("業者").Copy After:=Sheets(Sheets.Count)
            ActiveSheet.name = 業者名
            Set ws = Worksheets(業者名)
            row2 = ws.Cells(Rows.Count, 1).End(xlUp).row
            ws.Range("F4").Value = 業者名
            ws.Range(ws.Cells(row2 + 1, 1), ws.Cells(row2 + 1, 12)).Value = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, 12)).Value
            
            ws.Cells(row2 + 2, 10).Formula = Application.WorksheetFunction.Sum(Range("J9:J" & row2 & " "))
            ws.Cells(row2 + 2, 9).Value = "回数"
            ws.Cells(row2 + 2, 11).Value = "合計"
            ws.Cells(row2 + 2, 12).Formula = Application.WorksheetFunction.Sum(Range("K12:K" & row2 & " "))
                 
    End If

    Next
End Sub

ad.sys.soleil

2020/10/15 05:02

>････.Formula = "=SUM････計算式入れてますから、VBAのSub前後にこれを入れると早くなりますよ。 (前)開始後 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual (後)終了前 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic 参考まで。