VBAによる時系列順のコピぺ

質問

複数のデータがあり、元データはCSV形式なんですが、今までメモ帳として開き時系列順にコピペしていました。
1ファイルにつき1日分で10年分以上あるファイルもあります。
例えば「20090102（.csv）」、「20090104（.csv）」・・・、というようにファイル名が続きます。
「20090102（.csv）」の「2009」は年、「01」は月、「02」は日を表します。

これをExcelのVBAで時系列順にコピペしたいのですが、VBA初心者のため全く分からないのですが可能でしょうか？

条件、あるいは、規則としましては、
・CSVファイルとして開いてしまうとデータの内容が変わってしまうため、テキストファイル（.txt）として開き、一番下（画像の下のテキストファイルの赤い四角枠部分）に次のデータを時系列順にコピペする。
・元のデータのファイル名は上記のように「20090102（.csv）」であれば、「2009」（年）、「01」（月：2桁表示）、「02」（日：２桁表示）の表示順なのですが、必ずしも2009年から始まっているわけではなく、2001年の場合もあれば、2005年など異なる。
・元のデータである各ファイルは「20090102（.csv）」、「20090104（.csv）」のように時系列順なのですが、日付が飛ぶことがある（1月2日、1月4のように）。
・元のデータが格納されているフォルダを自由に変えられる。

画像の上が元のデータで、下がテキストファイルとして開いたときの内容です。
可能ならば、そのプログラムを教えてください。
Excel2010です。

回答よろしくお願いします。

回答No.4

eden3616 · ベストアンサー

>「フォルダを指定する場合」と「ファイルを指定する場合」とでは
>ダイアログの表示が異なるのですが、これは仕様でしょうか？
>「ファイルを指定する場合」での表示方法の方がやりやすかったです。

FileDialogオブジェクトを使用したフォルダ選択ダイアログに変更しました。
No3のコードと最下のVBAコードを差し換えてください。

　※実行時に「FileDialog(msoFileDialogFolderPicker)」でエラーが出る場合、
　　VBEのツール→参照設定より以下のライブラリを追加してください。
　　　　　　Microsoft Office xx.x Object Library
　　　　　　 　　　　　　（xx.xは数値）

また、フォルダ選択ダイアログには以下のようなものもありますので参照願います。
参考：http://officetanaka.net/excel/vba/tips/tips39.htm

■VBAコード
Sub Sample()
　　'準備
　　Dim Fbuf As Variant, buf As Variant, filnames() As Variant, filname As String
　　Dim Fso As Object, dirpath As String, fcnt As Long, cnt As Long
　　Set Fso = CreateObject("Scripting.FileSystemObject")

　　'フォルダ/ファイル選択ダイアログ切替用（mode=1：ファイル選択 / mode=0：フォルダ選択）
　　Const mode As Integer = 0 '★

　　'選択ダイアログの判定
　　If mode = 1 Then
　　　　'ファイル開くダイアログ表示：入力元のCSVファイル指定（複数可）
　　　　buf = Application.GetOpenFilename("CSVファイル (*.csv), *.csv", MultiSelect:=True)
　　Else
　　　　'フォルダ選択ダイアログ表示：全てのCSVファイルを対象
　　　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　　　If .Show = -1 Then 'OKボタンが押された場合の処理
　　　　　　　　dirpath = .SelectedItems(1) & "\" 'フォルダパス格納
　　　　　　　　buf = Dir(dirpath & "*.csv") 'CSVファイルの格納
　　　　　　End If
　　　　End With
　　End If
　　'ファイルパスの配列格納処理
　　If dirpath <> "" Then
　　　　'CSVファイルを取得
　　　　Do While buf <> ""
　　　　　　ReDim Preserve filnames(cnt + 1)
　　　　　　filnames(cnt) = dirpath & buf
　　　　　　cnt = cnt + 1
　　　　　　buf = Dir()
　　　　Loop
　　　　'CSVファイルが無い場合の処理
　　　　If cnt = 0 Then
　　　　　　MsgBox dirpath & " にCSVファイルがありません" & vbCrLf & "終了します"
　　　　　　Exit Sub '終了
　　　　Else
　　　　　　cnt = 0
　　　　End If
　　Else
　　　　'ファイルパスの格納
　　　　If IsArray(buf) = False Then
　　　　　　ReDim filnames(0)
　　　　Else
　　　　　　ReDim filnames(UBound(buf))
　　　　　　filnames = buf
　　　　End If
　　End If
　　'キャンセルで終了
　　If UBound(filnames) = 0 Then MsgBox "キャンセルされました": Exit Sub
　　fcnt = UBound(filnames)
　　'ファイル保存ダイアログ表示：出力先のテキストファイル指定
　　filname = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Name _
　　　　　　 , FileFilter:="テキストファイル(*.txt),*.txt" _
　　　　　　 , FilterIndex:=1, Title:="保存先の指定")
　　'キャンセルで終了
　　If filname = "False" Then MsgBox "キャンセルされました": Exit Sub
　　'出力用ファイルの用意
　　Open filname For Output As #2
　　　　'ファイル数の数だけ繰り返し
　　　　For Each Fbuf In filnames
　　　　　　If Fbuf <> "" Then
　　　　　　　　'CSVファイルをテキストデータとして開く
　　　　　　　　Open Fbuf For Input As #1
　　　　　　　　　　'ファイルの最終行まで繰り返し
　　　　　　　　　　Do Until EOF(1)
　　　　　　　　　　　　'ファイルの各行を読込み
　　　　　　　　　　　　Line Input #1, buf
　　　　　　　　　　　　'各行を出力用ファイルへ書き出し
　　　　　　　　　　　　Print #2, buf
　　　　　　　　　　Loop
　　　　　　　　'CSVファイルを閉じる
　　　　　　　　Close #1
　　　　　　End If
　　　　　　Application.StatusBar = Round(cnt * 100 / fcnt, 0) & " %"
　　　　　　cnt = cnt + 1
　　　　　　DoEvents
　　　　Next Fbuf
　　'出力用ファイルを閉じる
　　Close #2
　　MsgBox CStr(fcnt) & " ファイル終了しました"
　　Application.StatusBar = False
End Sub

お礼

再び回答を頂きましてありがとうございます。

なるほど、ダイアログにも種類があるんですね。
「ファイルを指定する場合」で表示されていたダイアログは「FileDialogオブジェクトを使う方法」だったんですね。
URLは大変参考になりました。
またコードを記述していただきありがとうございます。

本当にありがとうございました。

回答No.3

eden3616

No2の修正・変更及び補足です。

>ただ、その後何も起こりませんでした。
失礼しました。コードの返り値判定部分で強制的に終了するようになっておりました。
修正しました。

>ファイルサイズが多すぎて時間がかかっているのかと思い、合計で2.4MB程度で試しましたが、やはり保存されませんでした。

今回のコードは1ファイル8行で1000ファイル3.9MBでテスト動作することを確認しました。

>「特定のフォルダ内の全てのファイルを1つに統合」する場合、
>「特定のフォルダ内のファイルを指定して1つに統合」する場合、
>の二通りのコードを教えて頂けませんか？

処理部は同じため、ファイルパスの格納部を分けた形でコードを変更しました。
変数（mode）の値により、ファイル選択またはフォルダ選択を切り替えれるようにしています。
コード内の末尾に「★」を記述している行にて、modeの値を「0」または「1」で設定してください。

　フォルダを指定する場合　⇒　Const mode As Integer = 0 '★
　ファイルを指定する場合　⇒　Const mode As Integer = 1 '★

>「開発」→「挿入」→ボタン（フォームコントロール）でボタンを作成し
>「Sub 任意の文字_Click()」に変更すれば可能でしょうか？

　「Sub 任意の文字_Click()」の様式で記述する場合はフォームコントロールではなく、ActiveXコントロールのボタンかと思います。この場合はシートModuleにコードを記載し、プロシージャ名は「Sub 任意の文字_Click()」となります。（下記(3)を参照願います）
　フォームコントロールのボタン又はオートシェイプをボタンとして使用する場合は標準モジュールにコードを記載し、プロシージャ名は「「Sub 任意の文字()」」となります。（下記(1)又は(2)を参照願います）

(1)開発タブから、フォームコントロールでボタンを追加した場合は、先に標準モジュールを作成し、コードを貼り付けたのちにフォームコントロールのボタン追加時にダイアログが表示されますので、実行するマクロのプロシージャ名「Sample」を指定してください。
（「Sample」を変更する場合はコード貼付け時に変更願います）

(2)挿入タブから、オートシェイプを追加しボタンとして使う場合は、標準モジュールにコードを貼付け、挿入からオートシェイプを貼付け、右クリック→マクロの登録→「Sample」を指定してください。
（「Sample」を変更する場合はコード貼付け時に変更願います）

(3)開発タブから、ActiveXコントロールのボタンを追加した場合は、追加したボタンを(デザインモードで)右クリック→プロパティ→オブジェクト名を「任意の名前」とし、ボタンを貼り付けたシートのタブ（Sheet1やSheet2等）を右クリック→コードの表示→コードを貼り付けた後にコード冒頭の「Sample」の箇所を「任意の名前」に変更してください。

参照(1)(2)：http://www4.synapse.ne.jp/yone/excel2010/excel2010_macro_form.html
参照(3)：http://www4.synapse.ne.jp/yone/excel2010/excel2010_macro_command.html

>それでやってみたのですが、ボタンをクリックすると「※1」まで行えたため合っていると思うのですが。

ダイアログの表示はコード内での動作になりますので、ダイアログが表示されればコードが実行されていますので問題ありません。

■VBAコード

Sub Sample()
　　'準備
　　Dim Fbuf As Variant, buf As Variant, filnames() As Variant, filname As String
　　Dim Shell As Object, Fso As Object, dirpath As Variant, fcnt As Long, cnt As Long
　　Set Shell = CreateObject("Shell.Application")
　　Set Fso = CreateObject("Scripting.FileSystemObject")
　　Set dirpath = Nothing

　　'フォルダ/ファイル選択ダイアログ切替用（mode=1：ファイル選択 / mode=0：フォルダ選択）
　　Const mode As Integer = 0 '★

　　'選択ダイアログの判定
　　If mode = 1 Then
　　　　'ファイル開くダイアログ表示：入力元のCSVファイル指定（複数可）
　　　　buf = Application.GetOpenFilename("CSVファイル (*.csv), *.csv", MultiSelect:=True)
　　Else
　　　　'フォルダ選択ダイアログ表示：全てのCSVファイルを対象
　　　　Set dirpath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\")
　　End If
　　'ファイルパスの配列格納処理
　　If Not dirpath Is Nothing Then
　　　　'CSVファイルを取得
　　　　ReDim filnames(Fso.GetFolder(dirpath.Items.Item.Path).Files.Count)
　　　　For Each buf In Fso.GetFolder(dirpath.Items.Item.Path).Files
　　　　　　If buf Like "*.csv" Or buf Like "*.CSV" Then
　　　　　　　　filnames(cnt) = buf
　　　　　　　　cnt = cnt + 1
　　　　　　End If
　　　　Next buf
　　　　ReDim Preserve filnames(cnt)
　　　　cnt = 0
　　　　'CSVファイルが無い場合の処理
　　　　If UBound(filnames) = 0 Then
　　　　　　MsgBox dirpath.Items.Item.Path & " にCSVファイルがありません" & vbCrLf & "終了します"
　　　　　　Exit Sub '終了
　　　　End If
　　Else
　　　　'ファイルパスの格納
　　　　If IsArray(buf) = False Then
　　　　　　ReDim filnames(0)
　　　　Else
　　　　　　ReDim filnames(UBound(buf))
　　　　　　filnames = buf
　　　　End If
　　End If
　　'キャンセルで終了
　　If UBound(filnames) = 0 Then MsgBox "キャンセルされました": Exit Sub
　　fcnt = UBound(filnames)
　　'ファイル保存ダイアログ表示：出力先のテキストファイル指定
　　filname = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Name _
　　　　　　 , FileFilter:="テキストファイル(*.txt),*.txt" _
　　　　　　 , FilterIndex:=1, Title:="保存先の指定")
　　'キャンセルで終了
　　If filname = "False" Then MsgBox "キャンセルされました": Exit Sub
　　'出力用ファイルの用意
　　Open filname For Output As #2
　　　　'ファイル数の数だけ繰り返し
　　　　For Each Fbuf In filnames
　　　　　　Debug.Print cnt & "[" & Fbuf & "]"
　　　　　　If Fbuf <> "" Then
　　　　　　　　'CSVファイルをテキストデータとして開く
　　　　　　　　Open Fbuf For Input As #1
　　　　　　　　　　'ファイルの最終行まで繰り返し
　　　　　　　　　　Do Until EOF(1)
　　　　　　　　　　　　'ファイルの各行を読込み
　　　　　　　　　　　　Line Input #1, buf
　　　　　　　　　　　　'各行を出力用ファイルへ書き出し
　　　　　　　　　　　　Print #2, buf
　　　　　　　　　　Loop
　　　　　　　　'CSVファイルを閉じる
　　　　　　　　Close #1
　　　　　　End If
　　　　　　Application.StatusBar = Round(cnt * 100 / fcnt, 0) & " %"
　　　　　　cnt = cnt + 1
　　　　　　DoEvents
　　　　Next Fbuf
　　'出力用ファイルを閉じる
　　Close #2
　　MsgBox CStr(fcnt) & " ファイル終了しました"
　　Application.StatusBar = False
End Sub

お礼

回答ありがとうございます。

回答者様の新たな回答が来るまで自分なりに調べテキストファイルの統合に成功したのですが、保存先の指定でキャンセルをしたとき「False」というファイルが作成されてしまうためどうしたもんかと思っていました。

今回のコードでテキストファイルの統合に成功しました。
さらに、メッセージ付きのコードまで記載していただき大変感謝しております。
ボタンからでもできました。

「フォルダを指定する場合」と「ファイルを指定する場合」とではダイアログの表示が異なるのですが、これは仕様でしょうか？
「ファイルを指定する場合」での表示方法の方がやりやすかったです。

申し訳ありませんが、再び回答をいただけないでしょうか？
回答よろしくお願いします。

回答No.2

eden3616

>VBA初心者のため全く分からない

各コードの頭に処理内容のコメントを追加しています。参考にしてください。

>出力は、テキストファイル（.txt）で任意にファイル名を付け、
>保存したい場所に自由に保存できるという形にしたいです。

テキストファイルの保存先を指定するダイアログを表示するようにしました。

>入力側ですがプログラムを実行したとき、任意のフォルダを参照して
>（C、D、・・・ドライブと決めるのではなく）その中のファイルを
>1つのファイルに統合したいです。

特定フォルダ内の(全てのデータでなく)複数のCSVファイルを元データとして指定し、
１つのファイルに結合すると解釈します。

上記の意味合いであれば「ドライブレター：C:\　D:\」に関する文面をあえて
出されている事が気になっております。
解釈が異なっていれば補足願います。

■VBAコード
Sub Sample()
　　'準備
　　Dim Fbuf As Variant, buf As String, filnames As Variant, filname As String
　　'ファイル開くダイアログ表示：入力元のCSVファイル指定（複数可）
　　filnames = Application.GetOpenFilename("CSVファイル (*.csv), *.csv", MultiSelect:=True)
　　'キャンセルで終了
　　If IsArray(filnames) = False Then Exit Sub
　　'ファイル保存ダイアログ表示：出力先のテキストファイル指定
　　filname = Application.GetSaveAsFilename(InitialFileName:=ThisWorkbook.Name _
　　　　　　 , FileFilter:="テキストファイル(*.txt),*.txt" _
　　　　　　 , FilterIndex:=1, Title:="保存先の指定")
　　'キャンセルで終了
　　If IsArray(filname) = False Then Exit Sub
　　'出力用ファイルの用意
　　Open filname For Output As #2
　　　　'ファイル数の数だけ繰り返し
　　　　For Each Fbuf In filnames
　　　　　　'CSVファイルをテキストデータとして開く
　　　　　　Open Fbuf For Input As #1
　　　　　　　　'ファイルの最終行まで繰り返し
　　　　　　　　Do Until EOF(1)
　　　　　　　　　　'ファイルの各行を読込み
　　　　　　　　　　Line Input #1, buf
　　　　　　　　　　'各行を出力用ファイルへ書き出し
　　　　　　　　　　Print #2, buf
　　　　　　　　Loop
　　　　　　'CSVファイルを閉じる
　　　　　　Close #1
　　　　Next Fbuf
　　'出力用ファイルを閉じる
　　Close #2
End Sub

お礼

回答ありがとうございます。

回答者様のコードで「ファイルを開く」ダイアログが表示され、目的のファイルを指定し、「開く」を押すと「保存先の指定」ダイアログが表示され、任意にファイル名を付け、保存先まで自由に選択できました。
そして「保存」を押しました。
ここまでは成功しました。（※1）
ただ、その後何も起こりませんでした。
ファイルサイズが多すぎて時間がかかっているのかと思い、合計で2.4MB程度で試しましたが、やはり保存されませんでした。

>特定フォルダ内の(全てのデータでなく)複数のCSVファイルを元データとして指定し、
１つのファイルに結合すると解釈します。

そうですね。
合っていますが一応、
「特定のフォルダ内の全てのファイルを1つに統合」する場合、
「特定のフォルダ内のファイルを指定して1つに統合」する場合、
の二通りのコードを教えて頂けませんか？

ちなみに、ボタンから実行する場合、「開発」→「挿入」→ボタン（フォームコントロール）でボタンを作成し、「開発」→「Visual Basic」で、標準モジュールを作成し、回答者様のコードをコピペし「Sub Sample()」の部分を「Sub 任意の文字_Click()」に変更すれば可能でしょうか？
それでやってみたのですが、ボタンをクリックすると「※1」まで行えたため合っていると思うのですが。

お手数ですが、もう一度回答よろしくお願いします。

回答No.1

eden3616

どの様に出力したいのでしょうか？

1つのCSVファイルに複数行のデータが有り、1つのフォルダ内にあるCSVファイルを結合したい。その際ににデータの第1カンマまでの時系列にてソートした順としたいのであれば、以下のようなコードで可能ですが。
「"C:\ディレクトリパス\"」にて対象フォルダを指定してください（フォルダパスの最後には「\」を付けてください）。現在アクティブなシートのセルA1から下にCSVのデータが書出されます。

フォルダ内のCSVファイルの中身を順にA列へ書出します。開くファイルの順番はファイル名順になるため、おのずと時系列となるかと思います。
また再帰処理ではありませんので、サブフォルダ内のCSVは対象となりません。

カンマで区切りセルに分配するわけでないので、データの内容は変わらないかと思いますので、テキストファイルとして保存しないのであれば出力後のデータにてA列を選択してからテキストファイルへ張り付け保存してください。

■VBAコード
Sub Sample()
　　Dim Fbuf As String, buf As String, cnt As Long
　　Const Path As String = "C:\ディレクトリパス\"
　　Fbuf = Dir(Path & "*.csv")
　　Do While Fbuf <> ""
　　　　Open Path & Fbuf For Input As #1
　　　　　　Do Until EOF(1)
　　　　　　　　Line Input #1, buf
　　　　　　　　cnt = cnt + 1
　　　　　　　　Cells(cnt, 1).Value = buf
　　　　　　Loop
　　　　Close #1
　　　　Fbuf = Dir()
　　Loop
End Sub

お礼

回答ありがとうございます。

重要なことを記載し忘れていました。
出力は、テキストファイル（.txt）で任意にファイル名を付け、保存したい場所に自由に保存できるという形にしたいです。
もう一つあるのですが、入力側ですがプログラムを実行したとき、よく分かりませんが「ダイアログボックス」というのでしょうか？そのような表示が出て任意のフォルダを参照して（C、D、・・・ドライブと決めるのではなく）その中のファイルを1つのファイルに統合したいです。
入力側も出力側も自由に決められる形にしたいのですが。

お手数ですが、もう一度回答よろしくお願いします。