Option Explicit
 
Public Sub CSV_重複件数()
    Dim sh_arr As Variant       'シート名配列
    Dim col_arr As Variant      'カラム名配列
    sh_arr = Array("CSV")
    col_arr = Array("AK|AL", "AN|AO", "AQ|AR")
    Call Count_Dup(sh_arr, col_arr)
End Sub
Public Sub 重複_重複件数()
    Dim sh_arr As Variant       'シート名配列
    Dim col_arr As Variant      'カラム名配列
    sh_arr = Array("重複①", "重複②")
    col_arr = Array("G|I")
    Call Count_Dup(sh_arr, col_arr)
End Sub
'重複件数設定処理
Private Sub Count_Dup(sh_arr As Variant, col_arr As Variant)
    Dim i As Long
    Dim j As Long
    Dim ws As Worksheet
    Dim col As Variant
    Dim t1 As Double
    Dim t2 As Double
    Dim dict As Object
 
    t1 = Timer
    Set dict = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    Application.ScreenUpdating = False
    'カラムの組み合わせ分繰り返す
    For i = 0 To UBound(col_arr)
        '参照カラムと出力カラムに分ける
        col = Split(col_arr(i), "|")
        'dictionaryの初期化
        dict.RemoveAll
        'シートの数分繰り返す
        For j = 0 To UBound(sh_arr)
            'シートを設定し、該当シートの該当列の重複をdictionaryに登録する
            Set ws = Worksheets(sh_arr(j))
            Call set_key(ws, dict, col(0))
        Next
        'シートの数分繰り返す
        For j = 0 To UBound(sh_arr)
            'シートを設定し、該当シートの該当列へ重複件数を出力する
            Set ws = Worksheets(sh_arr(j))
            Call set_dup(ws, dict, col(0), col(1))
        Next
    Next
    Application.ScreenUpdating = True
    t2 = Timer
    MsgBox ("完了　処理時間=" & Int(t2 - t1) & "秒")
End Sub
'重複件数のdictionary登録
Private Sub set_key(ws As Worksheet, dict As Object, ByVal col1 As String)
    Dim maxrow As Long
    Dim arr As Variant
    Dim i As Long
    Dim key As Variant
    '指定列の最大行数取得
    maxrow = ws.Cells(Rows.Count, col1).End(xlUp).Row
    'メモリ配列へ転送
    arr = ws.Range(col1 & "2:" & col1 & maxrow).Value
    '2行目～最終行まで繰り返す
    For i = 1 To UBound(arr, 1)
        'キー取得
        key = LCase(arr(i, 1))
        If key <> "" Then
            'キーが空白でないなら件数をカウント
            If dict.exists(key) = False Then
                dict(key) = 1
            Else
                dict(key) = dict(key) + 1
            End If
        End If
    Next
End Sub
'重複件数の出力
Private Sub set_dup(ws As Worksheet, dict As Object, ByVal col1 As String, ByVal col2 As String)
    Dim maxrow As Long
    Dim arr As Variant
    Dim arr2 As Variant
    Dim i As Long
    Dim key As Variant
    '指定列の最大行数取得
    maxrow = ws.Cells(Rows.Count, col1).End(xlUp).Row
    'メモリ配列へ転送（キーの列と出力列の２つ）
    arr = ws.Range(col1 & "2:" & col1 & maxrow).Value
    arr2 = ws.Range(col2 & "2:" & col2 & maxrow).Value
    '2行目～最終行まで繰り返す
    For i = 1 To UBound(arr, 1)
        key = LCase(arr(i, 1))
        'キーが空白なら空白を出力、キーが空白でないなら重複件数を出力
        If key = "" Then
            arr2(i, 1) = ""
        Else
            arr2(i, 1) = dict(key)
        End If
    Next
    ws.Range(col2 & "2:" & col2 & maxrow).Value = arr2
End Sub
 

T3B0aW9uIEV4cGxpY2l0CgpQdWJsaWMgU3ViIENTVl/ph43opIfku7bmlbAoKQogICAgRGltIHNoX2FyciBBcyBWYXJpYW50ICAgICAgICfjgrfjg7zjg4jlkI3phY3liJcKICAgIERpbSBjb2xfYXJyIEFzIFZhcmlhbnQgICAgICAn44Kr44Op44Og5ZCN6YWN5YiXCiAgICBzaF9hcnIgPSBBcnJheSgiQ1NWIikKICAgIGNvbF9hcnIgPSBBcnJheSgiQUt8QUwiLCAiQU58QU8iLCAiQVF8QVIiKQogICAgQ2FsbCBDb3VudF9EdXAoc2hfYXJyLCBjb2xfYXJyKQpFbmQgU3ViClB1YmxpYyBTdWIg6YeN6KSHX+mHjeikh+S7tuaVsCgpCiAgICBEaW0gc2hfYXJyIEFzIFZhcmlhbnQgICAgICAgJ+OCt+ODvOODiOWQjemFjeWIlwogICAgRGltIGNvbF9hcnIgQXMgVmFyaWFudCAgICAgICfjgqvjg6njg6DlkI3phY3liJcKICAgIHNoX2FyciA9IEFycmF5KCLph43opIfikaAiLCAi6YeN6KSH4pGhIikKICAgIGNvbF9hcnIgPSBBcnJheSgiR3xJIikKICAgIENhbGwgQ291bnRfRHVwKHNoX2FyciwgY29sX2FycikKRW5kIFN1Ygon6YeN6KSH5Lu25pWw6Kit5a6a5Yem55CGClByaXZhdGUgU3ViIENvdW50X0R1cChzaF9hcnIgQXMgVmFyaWFudCwgY29sX2FyciBBcyBWYXJpYW50KQogICAgRGltIGkgQXMgTG9uZwogICAgRGltIGogQXMgTG9uZwogICAgRGltIHdzIEFzIFdvcmtzaGVldAogICAgRGltIGNvbCBBcyBWYXJpYW50CiAgICBEaW0gdDEgQXMgRG91YmxlCiAgICBEaW0gdDIgQXMgRG91YmxlCiAgICBEaW0gZGljdCBBcyBPYmplY3QKICAgIAogICAgdDEgPSBUaW1lcgogICAgU2V0IGRpY3QgPSBDcmVhdGVPYmplY3QoIlNjcmlwdGluZy5EaWN0aW9uYXJ5IikgJyDpgKPmg7PphY3liJfjga7lrprnvqkKICAgIEFwcGxpY2F0aW9uLlNjcmVlblVwZGF0aW5nID0gRmFsc2UKICAgICfjgqvjg6njg6Djga7ntYTjgb/lkIjjgo/jgZvliIbnubDjgorov5TjgZkKICAgIEZvciBpID0gMCBUbyBVQm91bmQoY29sX2FycikKICAgICAgICAn5Y+C54Wn44Kr44Op44Og44Go5Ye65Yqb44Kr44Op44Og44Gr5YiG44GR44KLCiAgICAgICAgY29sID0gU3BsaXQoY29sX2FycihpKSwgInwiKQogICAgICAgICdkaWN0aW9uYXJ544Gu5Yid5pyf5YyWCiAgICAgICAgZGljdC5SZW1vdmVBbGwKICAgICAgICAn44K344O844OI44Gu5pWw5YiG57mw44KK6L+U44GZCiAgICAgICAgRm9yIGogPSAwIFRvIFVCb3VuZChzaF9hcnIpCiAgICAgICAgICAgICfjgrfjg7zjg4jjgpLoqK3lrprjgZfjgIHoqbLlvZPjgrfjg7zjg4jjga7oqbLlvZPliJfjga7ph43opIfjgpJkaWN0aW9uYXJ544Gr55m76Yyy44GZ44KLCiAgICAgICAgICAgIFNldCB3cyA9IFdvcmtzaGVldHMoc2hfYXJyKGopKQogICAgICAgICAgICBDYWxsIHNldF9rZXkod3MsIGRpY3QsIGNvbCgwKSkKICAgICAgICBOZXh0CiAgICAgICAgJ+OCt+ODvOODiOOBruaVsOWIhue5sOOCiui/lOOBmQogICAgICAgIEZvciBqID0gMCBUbyBVQm91bmQoc2hfYXJyKQogICAgICAgICAgICAn44K344O844OI44KS6Kit5a6a44GX44CB6Kmy5b2T44K344O844OI44Gu6Kmy5b2T5YiX44G46YeN6KSH5Lu25pWw44KS5Ye65Yqb44GZ44KLCiAgICAgICAgICAgIFNldCB3cyA9IFdvcmtzaGVldHMoc2hfYXJyKGopKQogICAgICAgICAgICBDYWxsIHNldF9kdXAod3MsIGRpY3QsIGNvbCgwKSwgY29sKDEpKQogICAgICAgIE5leHQKICAgIE5leHQKICAgIEFwcGxpY2F0aW9uLlNjcmVlblVwZGF0aW5nID0gVHJ1ZQogICAgdDIgPSBUaW1lcgogICAgTXNnQm94ICgi5a6M5LqG44CA5Yem55CG5pmC6ZaTPSIgJiBJbnQodDIgLSB0MSkgJiAi56eSIikKRW5kIFN1Ygon6YeN6KSH5Lu25pWw44GuZGljdGlvbmFyeeeZu+mMsgpQcml2YXRlIFN1YiBzZXRfa2V5KHdzIEFzIFdvcmtzaGVldCwgZGljdCBBcyBPYmplY3QsIEJ5VmFsIGNvbDEgQXMgU3RyaW5nKQogICAgRGltIG1heHJvdyBBcyBMb25nCiAgICBEaW0gYXJyIEFzIFZhcmlhbnQKICAgIERpbSBpIEFzIExvbmcKICAgIERpbSBrZXkgQXMgVmFyaWFudAogICAgJ+aMh+WumuWIl+OBruacgOWkp+ihjOaVsOWPluW+lwogICAgbWF4cm93ID0gd3MuQ2VsbHMoUm93cy5Db3VudCwgY29sMSkuRW5kKHhsVXApLlJvdwogICAgJ+ODoeODouODqumFjeWIl+OBuOi7oumAgQogICAgYXJyID0gd3MuUmFuZ2UoY29sMSAmICIyOiIgJiBjb2wxICYgbWF4cm93KS5WYWx1ZQogICAgJzLooYznm67vvZ7mnIDntYLooYzjgb7jgafnubDjgorov5TjgZkKICAgIEZvciBpID0gMSBUbyBVQm91bmQoYXJyLCAxKQogICAgICAgICfjgq3jg7zlj5blvpcKICAgICAgICBrZXkgPSBMQ2FzZShhcnIoaSwgMSkpCiAgICAgICAgSWYga2V5IDw+ICIiIFRoZW4KICAgICAgICAgICAgJ+OCreODvOOBjOepuueZveOBp+OBquOBhOOBquOCieS7tuaVsOOCkuOCq+OCpuODs+ODiAogICAgICAgICAgICBJZiBkaWN0LmV4aXN0cyhrZXkpID0gRmFsc2UgVGhlbgogICAgICAgICAgICAgICAgZGljdChrZXkpID0gMQogICAgICAgICAgICBFbHNlCiAgICAgICAgICAgICAgICBkaWN0KGtleSkgPSBkaWN0KGtleSkgKyAxCiAgICAgICAgICAgIEVuZCBJZgogICAgICAgIEVuZCBJZgogICAgTmV4dApFbmQgU3ViCifph43opIfku7bmlbDjga7lh7rlipsKUHJpdmF0ZSBTdWIgc2V0X2R1cCh3cyBBcyBXb3Jrc2hlZXQsIGRpY3QgQXMgT2JqZWN0LCBCeVZhbCBjb2wxIEFzIFN0cmluZywgQnlWYWwgY29sMiBBcyBTdHJpbmcpCiAgICBEaW0gbWF4cm93IEFzIExvbmcKICAgIERpbSBhcnIgQXMgVmFyaWFudAogICAgRGltIGFycjIgQXMgVmFyaWFudAogICAgRGltIGkgQXMgTG9uZwogICAgRGltIGtleSBBcyBWYXJpYW50CiAgICAn5oyH5a6a5YiX44Gu5pyA5aSn6KGM5pWw5Y+W5b6XCiAgICBtYXhyb3cgPSB3cy5DZWxscyhSb3dzLkNvdW50LCBjb2wxKS5FbmQoeGxVcCkuUm93CiAgICAn44Oh44Oi44Oq6YWN5YiX44G46Lui6YCB77yI44Kt44O844Gu5YiX44Go5Ye65Yqb5YiX44Gu77yS44Gk77yJCiAgICBhcnIgPSB3cy5SYW5nZShjb2wxICYgIjI6IiAmIGNvbDEgJiBtYXhyb3cpLlZhbHVlCiAgICBhcnIyID0gd3MuUmFuZ2UoY29sMiAmICIyOiIgJiBjb2wyICYgbWF4cm93KS5WYWx1ZQogICAgJzLooYznm67vvZ7mnIDntYLooYzjgb7jgafnubDjgorov5TjgZkKICAgIEZvciBpID0gMSBUbyBVQm91bmQoYXJyLCAxKQogICAgICAgIGtleSA9IExDYXNlKGFycihpLCAxKSkKICAgICAgICAn44Kt44O844GM56m655m944Gq44KJ56m655m944KS5Ye65Yqb44CB44Kt44O844GM56m655m944Gn44Gq44GE44Gq44KJ6YeN6KSH5Lu25pWw44KS5Ye65YqbCiAgICAgICAgSWYga2V5ID0gIiIgVGhlbgogICAgICAgICAgICBhcnIyKGksIDEpID0gIiIKICAgICAgICBFbHNlCiAgICAgICAgICAgIGFycjIoaSwgMSkgPSBkaWN0KGtleSkKICAgICAgICBFbmQgSWYKICAgIE5leHQKICAgIHdzLlJhbmdlKGNvbDIgJiAiMjoiICYgY29sMiAmIG1heHJvdykuVmFsdWUgPSBhcnIyCkVuZCBTdWIK