経緯
手作業でCSVの1列目の項目で集計して欲しいと言われたので手作業したくないからVBAを作成。
ついでに１から3列目までの情報を基に重複を削除する。
重複しているものをサマリしてカウントする。
そんな感じのソースを3つ作った。
（もう少し改良すれば汎用的に使える気がする・・・。）
使用用途
CSVファイルの集計をしたい。
複数CSVに分かれてる同じような内容をまとめて収集したいなど
テスト時のCSVの中身
山田,12358,6759966山田,12358,6789566
山田,12358,6789956
山田,12358,6789966
山田,12368,6789966
山田,12558,6789966
山田,15358,6789966
田中,12358,7759966
田中,12358,7789566
田中,12358,7789956
田中,12358,7789966
田中,12368,7789966
田中,12558,7789966
田中,15358,7789966
田中,12358,7789966
二郎,12368,7789966
二郎,12558,7789966
二郎,15358,7789966
二郎,12358,7789566
二郎,12358,7789956
二郎,12358,7759966
山田,12358,6789966
熊田隈,12368,6789966
熊田隈,12558,6789966
熊田隈,15358,6789966
熊田隈,12358,6789566
山田,12358,6789956
山田,12358,6759966
Excelファイル1シート目のA2から下に記述されているCSVファイルのパスを基に集計を行う。
Sub CountItemsFromCSV()
Dim ws As Worksheet
Dim rowCount As Long
Dim i As Integer
Dim j As Integer
Dim key As Variant
Dim counts As Object
Dim filePath As String
Dim currentValue As Variant
Dim currentCount As Long
' シートを取得
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適宜変更してください
' 初期化
Set counts = CreateObject("Scripting.Dictionary")
' ファイルごとに処理
j = 2 ' シート上での開始行
Do While ws.Cells(j, 1).Value <> "" ' シート上で空白行に到達するまで繰り返す
' ファイルパスを取得
filePath = ws.Cells(j, 1).Value
' ファイルを開く
Open filePath For Input As #1
' 各数値の出現回数を集計
Do While Not EOF(1)
Line Input #1, key
currentValue = Split(key, ",")(0) ' 最初の要素をキーとする
If Not counts.Exists(currentValue) Then
counts.Add currentValue, 1
Else
counts(currentValue) = counts(currentValue) + 1
End If
Loop
' ファイルを閉じる
Close #1
' 次の行に移動
j = j + 1
Loop
' 結果をシートに出力
ws.Range("D2").Resize(counts.Count, 2).Value = WorksheetFunction.Transpose(Array("Value", "Count"))
j = 2
For Each key In counts.Keys
ws.Cells(j, 4).Value = key
ws.Cells(j, 5).Value = counts(key)
j = j + 1
Next key
End Sub
表示結果
CSVの1から3列目の情報をシート生成して表示する。
Sub RemoveDuplicatesFromCSV()
Dim ws As Worksheet
Dim newWs As Worksheet
Dim lastRow As Long
Dim i As Long
Dim key As Variant
Dim uniqueValues As Object
Dim filePath As String
Dim currentValue As Variant
Dim csvData As Variant ' CSVデータを保持する配列
' 新しいシートを作成
Set newWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
newWs.Name = "Data_" + Format(Now(), "YYYYMMDD_HHMMSS")
' シートを取得
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適宜変更してください
' 初期化
Set uniqueValues = CreateObject("Scripting.Dictionary")
' 最終行を取得
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' CSVファイルのデータを重複なしでコピー
For i = 2 To lastRow
' ファイルパスを取得
filePath = ws.Cells(i, 1).Value
' CSVファイルのデータを配列に読み込む
csvData = LoadCSVData(filePath)
' CSVのデータを重複なしでコピー
For j = LBound(csvData, 1) To UBound(csvData, 1)
key = csvData(j, 1) & "-" & csvData(j, 2) & "-" & csvData(j, 3)
If Not uniqueValues.Exists(key) Then
uniqueValues.Add key, csvData(j, 1) & "," & csvData(j, 2) & "," & csvData(j, 3)
End If
Next j
Next i
' 結果を新しいシートに出力
newWs.Range("A1").Value = "Column1"
newWs.Range("B1").Value = "Column2"
newWs.Range("C1").Value = "Column3"
i = 2
For Each key In uniqueValues.Keys
currentValue = Split(uniqueValues(key), ",")
newWs.Cells(i, 1).Value = currentValue(0)
newWs.Cells(i, 2).Value = currentValue(1)
newWs.Cells(i, 3).Value = currentValue(2)
i = i + 1
Next key
End Sub
Function LoadCSVData(filePath As String) As Variant
Dim data As String
Dim dataArray() As String
Dim result() As Variant
Dim rowNum As Long
Dim colNum As Long
Dim i As Long
Dim j As Long
Open filePath For Input As #1
Do Until EOF(1)
Line Input #1, data
dataArray = Split(data, ",")
rowNum = rowNum + 1
colNum = UBound(dataArray) + 1
Loop
Close #1
ReDim result(1 To rowNum, 1 To colNum)
rowNum = 0
Open filePath For Input As #1
Do Until EOF(1)
Line Input #1, data
dataArray = Split(data, ",")
rowNum = rowNum + 1
For j = 1 To colNum
result(rowNum, j) = dataArray(j - 1)
Next j
Loop
Close #1
LoadCSVData = result
End Function
表示結果
※長いので割愛
重複データを削除した状態の件数を取得する。
Sub SummarizeData()
Dim ws As Worksheet
Dim newWs As Worksheet
Dim lastRow As Long
Dim i As Long
Dim key As Variant
Dim uniqueValues As Object
Dim filePath As String
Dim currentValue As Variant
Dim csvData As Variant ' CSVデータを保持する配列
Dim summaryCounts As Object ' サマリーカウントを保持するオブジェクト
' 新しいシートを作成
Set newWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
newWs.Name = "Summary" + Format(Now(), "YYYYMMDD_HHMMSS")
' シートを取得
Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適宜変更してください
' 初期化
Set uniqueValues = CreateObject("Scripting.Dictionary")
Set summaryCounts = CreateObject("Scripting.Dictionary")
' 最終行を取得
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' CSVファイルのデータを重複なしでコピー
For i = 2 To lastRow
' ファイルパスを取得
filePath = ws.Cells(i, 1).Value
' CSVファイルのデータを配列に読み込む
csvData = LoadCSVData(filePath)
' CSVのデータを重複なしでコピー
For j = LBound(csvData, 1) To UBound(csvData, 1)
key = csvData(j, 1) & "-" & csvData(j, 2) & "-" & csvData(j, 3)
If Not uniqueValues.Exists(key) Then
uniqueValues.Add key, csvData(j, 1) & "," & csvData(j, 2) & "," & csvData(j, 3)
' サマリーカウントを更新
If Not summaryCounts.Exists(csvData(j, 1)) Then
summaryCounts.Add csvData(j, 1), 1
Else
summaryCounts(csvData(j, 1)) = summaryCounts(csvData(j, 1)) + 1
End If
End If
Next j
Next i
' サマリーを新しいシートに出力
newWs.Range("A1").Value = "Column1"
newWs.Range("B1").Value = "Count"
i = 2
For Each key In summaryCounts.Keys
newWs.Cells(i, 1).Value = key
newWs.Cells(i, 2).Value = summaryCounts(key)
i = i + 1
Next key
End Sub
Function LoadCSVData(filePath As String) As Variant
Dim data As String
Dim dataArray() As String
Dim result() As Variant
Dim rowNum As Long
Dim colNum As Long
Dim i As Long
Dim j As Long
Open filePath For Input As #1
Do Until EOF(1)
Line Input #1, data
dataArray = Split(data, ",")
rowNum = rowNum + 1
colNum = UBound(dataArray) + 1
Loop
Close #1
ReDim result(1 To rowNum, 1 To colNum)
rowNum = 0
Open filePath For Input As #1
Do Until EOF(1)
Line Input #1, data
dataArray = Split(data, ",")
rowNum = rowNum + 1
For j = 1 To colNum
result(rowNum, j) = dataArray(j - 1)
Next j
Loop
Close #1
LoadCSVData = result
End Function
だいぶ突貫工事で作ったソースだけど動作的には問題なし。 強いて言うなら一番上のソースが1シート目にデータを書きだしている事、他と同じで別シートを作るようにすればよかった。
改良すれば他の目的にも使えそうな気もする。