CSVファイルを１行目の内容で分類して結合するマクロ
2021年02月23日
仕事で急遽必要になり、突貫で作成。
過去のソースを流用して１時間でできた。
◆目的◆
フォルダ内にCSVファイルの一覧があり、１行目が日付情報、
２行目以降が登録データになっている。
CSVファイルをサイトに取り込む際に、
１アカウント１日あたりファイルっていう縛りがあり、
日付別にCSVファイルをまとめなきゃいけなくなった。
◆手順◆
１．ダイアログを表示して解析対象のパスを取得
２．Dir関数を使ってフォルダ内のファイル一覧を取得
（今回は、VBAで作られたCSVを結合するのでShift-Jisのみ）
３．ファイルの中身を１行ずつ読み込む
４．Dictionary配列を定義し、１行目の日付をキーに２行目以降をアペンド
（キーの存在チェックしてなければキー登録、あれば値更新）
５．全ファイル繰り返し
６．キー配列を定義して、Dictionaryカウントでループ
７．キーごとに値をCSV出力（Printを使用）
◆注意点◆
Dictionary配列に改行「chr(10)」を格納しても「・」が出力されるので
一旦「"†"」で格納して、Print時に「chr(10)」へReplace
以下ソース
過去のソースを流用して１時間でできた。
◆目的◆
フォルダ内にCSVファイルの一覧があり、１行目が日付情報、
２行目以降が登録データになっている。
CSVファイルをサイトに取り込む際に、
１アカウント１日あたりファイルっていう縛りがあり、
日付別にCSVファイルをまとめなきゃいけなくなった。
◆手順◆
１．ダイアログを表示して解析対象のパスを取得
２．Dir関数を使ってフォルダ内のファイル一覧を取得
（今回は、VBAで作られたCSVを結合するのでShift-Jisのみ）
３．ファイルの中身を１行ずつ読み込む
４．Dictionary配列を定義し、１行目の日付をキーに２行目以降をアペンド
（キーの存在チェックしてなければキー登録、あれば値更新）
５．全ファイル繰り返し
６．キー配列を定義して、Dictionaryカウントでループ
７．キーごとに値をCSV出力（Printを使用）
◆注意点◆
Dictionary配列に改行「chr(10)」を格納しても「・」が出力されるので
一旦「"†"」で格納して、Print時に「chr(10)」へReplace
以下ソース
Sub 指定フォルダのcsvファイルを結合()
Dim strPATHNAME As String
strPATHNAME = フォルダ指定
If strPATHNAME = "" Then Exit Sub
Dim WS As Worksheet: Set WS = Worksheets("ファイル一覧")
Dim tmp As Variant, i As Long
Dim TextLine As String
Dim Dic, cnt As Long
Set Dic = CreateObject("Scripting.Dictionary")
Dim Gyo As Long: Gyo = 1
Dim cGyo As Long
Dim strDate As String
WS.Range(WS.Cells(2, 1), WS.Cells(Rows.Count, 4)).ClearContents
Const cnsDIR = "\*.csv"
Dim strFILENAME As String
strFILENAME = Dir(strPATHNAME & cnsDIR, vbNormal) 'フォルダ内のファイル名をゲット(1つ目）
Do While strFILENAME <> ""
If Left(strFILENAME, 1) <> "†" Then
Gyo = Gyo + 1
WS.Cells(Gyo, 1).Value = Gyo - 1
WS.Cells(Gyo, 2).Value = strFILENAME
cGyo = 0
Open strPATHNAME & "\" & strFILENAME For Input As #1 ' ファイルを開きます
Do While Not EOF(1) ' ファイルの終端までループを繰り返します。
Line Input #1, TextLine ' 行を変数に読み込みます。
cGyo = cGyo + 1
If cGyo = 1 Then
strDate = TextLine
Else
If Not Dic.exists(strDate) Then
Dic.Add strDate, TextLine & "†"
Else
Dic(strDate) = Dic(strDate) & TextLine & "†"
End If
End If
Loop
Close #1
WS.Cells(Gyo, 3).Value = strDate
WS.Cells(Gyo, 4).Value = cGyo
End If
strFILENAME = Dir() 'フォルダ内のファイル名をゲット(２つ目以降）
Loop
'Stop
Dim Keys: Keys = Dic.Keys
For i = 1 To Dic.Count
Open strPATHNAME & "\" & "†" & Keys(i - 1) & ".csv" For Output As #1
Print #1, Keys(i - 1) & Chr(10) & Replace(Left(Dic(Keys(i - 1)), Len(Dic(Keys(i - 1))) - 1), "†", Chr(10))
Close #1
Next i
MsgBox Gyo - 1 & "件のCSVファイルから" & Dic.Count & "件のCSVファイルを作成しました"
End Sub
Function フォルダ指定()
Dim strPATHNAME As String
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject") 'オブジェクトを使うことを宣言
'----------------フォルダパス指定------------------------
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
strPATHNAME = .SelectedItems(1)
End If
End With
If strPATHNAME = "" Then MsgBox "キャンセルしました"
Set FSO = Nothing
フォルダ指定 = strPATHNAME
End Function
PR
Comment