フォルダ内のCSVファイルをエクセルシートに転記
2020年02月05日
今回はCSVファイルの転記について。
携帯電話の通話料に応じて費用按分をしているのだが、
回線ごとの通話料は利用明細を見ないとわからない。
仕方なく、回線ごとにシートを分けて利用明細をコピペしていたが、
いい加減めんどくさくなったので、
回線ごちゃまぜで１つのシートにまとめて
表計算で集計することにした。
ダウンロードしたデータのファイル名に回線名の記載がない。
同じデータを２つダウンロードしていても気づかないので
Dic配列を使って重複は排除することにした。
また例によって、オフィス田中氏のHPにお世話になりました。
処理の流れは以下のとおり。
まず対象のフォルダを指定。今回は一発ものなので固定。
dir関数を使ってフォルダ内のファイルを取得。
対象ファイルがなくなるまでループ。
dir関数で取得したファイルからフルパスを取得してファイルを開く。
各行のデータをDic配列に格納
（新出なら格納、既出なら値に目印を追加）
Dicの値をA列へ、キーをB列へ出力。
キー配列から区切り文字でsplitして、出力配列に格納。
C列以降に出力配列を格納。
そんな感じで、以下ソース。
携帯電話の通話料に応じて費用按分をしているのだが、
回線ごとの通話料は利用明細を見ないとわからない。
仕方なく、回線ごとにシートを分けて利用明細をコピペしていたが、
いい加減めんどくさくなったので、
回線ごちゃまぜで１つのシートにまとめて
表計算で集計することにした。
ダウンロードしたデータのファイル名に回線名の記載がない。
同じデータを２つダウンロードしていても気づかないので
Dic配列を使って重複は排除することにした。
また例によって、オフィス田中氏のHPにお世話になりました。
'ファイルの一覧を取得
'http://officetanaka.net/excel/vba/file/file07.htm
'
'テキストファイルを読み込む
'http://officetanaka.net/excel/vba/file/file08b.htm
処理の流れは以下のとおり。
まず対象のフォルダを指定。今回は一発ものなので固定。
dir関数を使ってフォルダ内のファイルを取得。
対象ファイルがなくなるまでループ。
dir関数で取得したファイルからフルパスを取得してファイルを開く。
各行のデータをDic配列に格納
（新出なら格納、既出なら値に目印を追加）
Dicの値をA列へ、キーをB列へ出力。
キー配列から区切り文字でsplitして、出力配列に格納。
C列以降に出力配列を格納。
そんな感じで、以下ソース。
Sub フォルダ内のCSVファイルを転記()
Const Path As String = "D:\Dropbox\xlsエクセル関連\IIJ 通話ログ\ログ\"
Const EXT = "*.csv"
Dim fName As String: fName = Dir(Path & EXT)
Dim Dic, buf As String
Set Dic = CreateObject("Scripting.Dictionary")
Do While fName <> ""
Open Path & fName For Input As #1
'ファイルを開いて
Do Until EOF(1)
Line Input #1, buf
If Not Dic.exists(buf) Then
Dic.Add buf, fName '新規キーを登録 値は１
Else
Dic(buf) = Dic(buf) & "†" '既出のキーは、ファイル名に印
End If
Loop
Close #1
fName = Dir()
Loop
Dim Keys, Items
Keys = Dic.Keys
Items = Dic.Items
Dim iRowMax: iRowMax = UBound(Keys) - LBound(Keys) + 1
Cells(2, 1).Resize(iRowMax, 1).Value = WorksheetFunction.Transpose(Items) 'ファイル名
Cells(2, 2).Resize(iRowMax, 1).Value = WorksheetFunction.Transpose(Keys) 'CSVデータ（生）
Cells(1, 1) = "ファイル"
Cells(1, 2) = "CSV生データ"
Dim tmp: tmp = Split(Cells(2, 2), ",")
Dim iColMax: iColMax = UBound(tmp, 1) - LBound(tmp, 1)
Dim Arr(): ReDim Arr(iRowMax, iColMax)
Dim i As Long, j As Long
For i = 0 To UBound(Keys)
tmp = Split(Keys(i), ",")
For j = 0 To iColMax
Arr(i, j) = Replace(tmp(j), """", "")
Next j
Next i
Cells(2, 3).Resize(iRowMax, iColMax + 1).Value = Arr
End Sub
PR
Comment