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
'メモリ配列へ転送(キーの列と出力列の2つ)
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