B列へ新たにコピペを繰り返して行きA列とB列を比較してA列に無いデータは
B列に条件式書式で=AND(COUNTIF(A:A,B2)=0,LEN(B2)>1)でB列のデータを赤文字にしています
そこでB列の赤文字となったデータを下記のマクロ
Sub Macro100()
 '
     Dim Cell As Range
 '
     Shell "Notepad", vbNormalFocus
     Set Cell = Cells(Rows.Count, "B").End(xlUp)
 '
     For Each Cell In Range([B1], Cell)
 '
         If Cell.DisplayFormat.Font.Color = vbRed Then
             DoEvents
             Cell.Copy
             SendKeys "^V"
         End If
     Next Cell
     Dim WshShell
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.SendKeys "{NUMLOCK}"
    Set WshShell = Nothing
 End Sub
で、メモ帳を起動して赤文字になった今回追加分をメモ帳に書き出します
そこで今回新たにお願いしたいのはA列の最下行よりB列の最下行が超えた時点で、チェンジイベントマクロが発動されてこのマクロ100が自動で起動するようにしてください。

＞A列の最下行よりB列の最下行が超えた時点で、チェンジイベントマクロが発動されて
は出来ないので、
ワークシートチェンジイベントで判定しています

ThisWorkbookモジュール

Private Sub Workbook_Open()
    Sheet1.wschang  'Sheet1は当該シートのCodeNameに変更のこと
End Sub

該当シートモジュール

Private Sub Worksheet_Change(ByVal Target As Range)
    Static flg As Boolean
    If Target Is Nothing Then    '起動時はflg初期化のみ
        flg = Cells(Rows.Count, "A").End(xlUp).Row < Cells(Rows.Count, "B").End(xlUp).Row
    ElseIf Not Intersect(Target, Columns("A:B")) Is Nothing Then    'AorB列変化時
        If Cells(Rows.Count, "A").End(xlUp).Row < Cells(Rows.Count, "B").End(xlUp).Row Then
            'A列の最下行よりB列の最下行が大きい
            If Not flg Then '前回大きくない　＝　今超えた
                Call a  'Macro100
                flg = True  '大きい
            End If
        Else
            flg = False     '大きくない
        End If
    End If
End Sub

Sub wschang()   '初期化コード（Worksheet_ChangeをPrivate属性のままにしたかったので作成）
    Worksheet_Change Nothing
End Sub

Private Sub a() '動作確認コード
    MsgBox ""
End Sub

This Workbookモジュールには
すでに下記のコードが入っているので
シートモジュールに書き込むコードでチェンジイベントマクロだけではこのマクロは作成できないので、あきらめるしかないのですか？
Private Sub Workbook_Open()
    [A:B].FormatConditions.Delete
 '
     [A2:A3000].Select
     Selection.FormatConditions.Add Type:=xlExpression, _
         Formula1:="=AND(COUNTIF(B:B,A2)=0,LEN(A2)>1)"
     Selection.FormatConditions(1).Font.Color = vbBlue
 '
     [B2:B3000].Select
     Selection.FormatConditions.Add Type:=xlExpression, _
         Formula1:="=AND(COUNTIF(A:A,B2)=0,LEN(B2)>1)"
     Selection.FormatConditions(1).Font.Color = vbRed
    Columns("B:B").Select
    Selection.ClearContents
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "今回"
    ActiveCell.Characters(1, 2).PhoneticCharacters = "コンカイ"
'
     Dim Count As Long
     Dim Row As Long
     Dim Cell As String
 '
     For Row = 2 To Cells(Rows.Count, "A").End(xlUp).Row
         Cell = Cells(Row, "A")
 '
         If Cell = "" Then
         ElseIf Len(Cell) = 1 And Cell >= "ぁ" And Cell <= "ん" Then
         Else
             Count = Count + 1
         End If
     Next Row
     [A1] = Count
     '[A1] = Count + 17
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Columns("B:B").Select
    Selection.Copy
    Columns("A:A").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End Sub

シートの指定が無かったり、イベントの抑制が無いので、以下に書き換えて下さい。
（他にも私の好みに書き換えていますが、お許しください）

Private Sub Workbook_Open()
    Dim Count As Long
    Dim iRow As Long
    Dim Cell As String
    
    Application.EnableEvents = False    'セルの値をいじるので無駄なイベントを抑制
    With Sheet1                         'シートを指定（１枚しか無くとも私は書きます）
        .Range("A:B").FormatConditions.Delete
        With .Range("A2:A3000")
            .FormatConditions.Add xlExpression, , "=AND(COUNTIF(B:B,A2)=0,LEN(A2)>1)"
            .FormatConditions(1).Font.Color = vbBlue
        End With
        With .Range("B2:B3000")
            .FormatConditions.Add xlExpression, , "=AND(COUNTIF(A:A,B2)=0,LEN(B2)>1)"
            .FormatConditions(1).Font.Color = vbRed
        End With
        .Columns("B:B").ClearContents
        .Range("B1").Value = "今回"
        .Range("B1").Characters(1, 2).PhoneticCharacters = "コンカイ"
        Application.Goto .Range("B1")
'
        For iRow = 2 To Cells(.Rows.Count, "A").End(xlUp).Row
            Cell = .Cells(iRow, "A").Value
            If Cell = "" Then
            ElseIf Len(Cell) = 1 And Cell >= "ぁ" And Cell <= "ん" Then
            Else
                Count = Count + 1
            End If
        Next iRow
        .Range("A1").Value = Count
        .wschang    '上記処理なら必ずflgはfalseなので不要ではある。
    End With
    Application.EnableEvents = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.EnableEvents = False
    With Sheet1
        .Columns("B:B").Copy
        .Columns("A:A").PasteSpecial xlPasteValues
    End With
    Application.CutCopyMode = False 'クリップボードのクリア
    Application.EnableEvents = True '別ブックのイベントを許す
End Sub

＞このコードは単なるメッセージボックスが出現して動作確認OKの判定結果を表示するもの・・・・
Macro100も完動するようにして欲しいということですか？
そうでないなら
＞＞            If Not flg Then '前回大きくない　＝　今超えた
＞＞                Call a  'Macro100
＞＞                flg = True  '大きい
＞＞           End If
 の              Call a  'Macro100　を
                Call Macro100
　に変更下さい

＞このブックはWorkbook_BeforeCloseのイベントマクロに従い上書き保存して閉じてしまいます
マクロで自動化したいならWorkbook.Saveメソッドを追加すれば良いです。
そのコードを追加して欲しいのですか？

回答して欲しいことと、今の状況は回答者に明確に伝わるようお書き下さい。