重複リストからの抽出の改良例

 Sub 抽出マッチした値()
    Dim lastRowA As Long
    Dim lastRowI As Long
    Dim i As Long, j As Long
    
    ' A列とI列の最終行を取得
    lastRowA = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    lastRowI = Sheets("Sheet1").Cells(Rows.Count, "I").End(xlUp).Row
    
    ' B列とC列を初期化
    Sheets("Sheet1").Range("B1:C" & lastRowA).ClearContents
    
    ' A列の各セルをループ
    For i = 1 To lastRowA
        ' A列の値がI列にマッチした場合
        For j = 1 To lastRowI
            If Sheets("Sheet1").Cells(i, "A").Value = Sheets("Sheet1").Cells(j, "I").Value Then
                ' 重複がある場合、C列にJ列の値を書き込む
                If i <> j Then
                    Sheets("Sheet1").Cells(i, "C").Value = Sheets("Sheet1").Cells(j, "J").Value
                    Exit For
                End If
                ' マッチした場合、B列にJ列の値を書き込む
                Sheets("Sheet1").Cells(i, "B").Value = Sheets("Sheet1").Cells(j, "J").Value
            End If
        Next j
        
       
        
    Next i
End Sub