日付順にテキストを開いて書き込むエクセルマクロ

質問

あるフォルダの中に「abc#1xyz_201308.txt」という形のテキストファイルがあり、
ボタンを押すと、直近1年分のファイルに対して中身のデータをシート3に書き込むような
マクロを作りたいのですが、直近１年分のものに対して所定の操作を行うやり方が分かりません

例として、「C:\Users\Owner\Documents」に「abc#1xyz_201308.txt」の形のファイルが
１年以上分ある場合で教えていただけますか？
（テキストは日付以外は同じ名前、つまりabc#1xyz_201307.txtやabc#1xyz_201306.txtが存在し
それ以外の名前のものはこのフォルダにはありません。またフォルダ内には順番通り入っていませんが
シートに書き込むのは古いものから順にしたいです）

回答No.2

cj_mover

> 直近1年分のファイル
この意味を解っていなかったので、やり直しました。
例えば今なら、201209-201308の一年分のテキストファイルを拾い上げます。
期間を、月単位で前後に調整出来るように書いてます。
例えば
　　Const fAdjMonth = -1
と変更すると、今なら、201208-201307の一年分、になります。
設計、ガラッと変えました。わりと、教科書的な書き方のように思います。
Ａ列に縦に並べまて出力するように書きましたけど、その後の処理も必要ならば、
恐らく手作業でも出来る内容だと思いますから、マクロの記録でも録って
書き足すようにしてください。

' ' 標準モジュール専用

Sub Re8257248cj()

　　Const fFolderPath = "C:\Users\Owner\Documents"　　' 指定フォルダ名
　　Const fFileNamePattern = "abc#1xyz_000000.txt"　　' ファイル名パターン。年月に相当する部分に"000000"

　　Const fAdjMonth = 0　　' 期間を月単位で前後に調整する値

　　Dim sFileName As String　　' 各ファイル名。"年月"に相当する部分だけ順次置換
　　Dim sTempLine As String　　' テキストデータを各一行ずつ読み込む変数
　　Dim sMsg As String　　' 見つからないファイルがあった場合の告知用文字列

　　Dim nPosYYYYMM As Long　　' ファイル名の中で"年月"に相当する桁位置
　　Dim cnLines As Long　　' 出力する行位置、をカウントアップ
　　Dim nYear As Long　　' 開始年。1年前の西暦年
　　Dim nMonth As Long　　' 開始月。当月の月
　　Dim i As Long　　' ループ用
　　Dim nFree As Integer　　' 使用可能なファイル番号

　　' ' アプリケーションの描画更新停止
　　Application.ScreenUpdating = False

　　' ' シート3を選択。シート名要指定
　　Sheets("Sheet3").Select
　　' ' Ａ列の値を消去
　　Range("A:A").ClearContents

　　' ' ファイル名パターンを（フォルダパスを加えて）フルネームに
　　sFileName = fFolderPath & "\" & fFileNamePattern

　　' ' ファイル名の中で"年月"に相当する桁位置を取得
　　nPosYYYYMM = InStr(sFileName, "000000")

　　' ' 開始年。1年前の西暦年
　　nYear = Year(Date) - 1
　　' ' 開始月。当月の月（調整可）
　　nMonth = Month(Date) + fAdjMonth

　　' ' Open ステートメントで使用可能なファイル番号
　　nFree = FreeFile

　　' ' 開始月（前年同月）から終了月（昨月）までループ
　　For i = nMonth To nMonth + 11

　　　　' ' ファイル名の中で"年月"に相当する部分を置換
　　　　Mid(sFileName, nPosYYYYMM) = Format(DateSerial(nYear, i, 1), "yyyymm")

　　　　' ' ファイルが存在するか確認
　　　　If Dir(sFileName) <> "" Then　　' 存在するなら
　　　　　　' ' ファイルを読み込み用に開く
　　　　　　Open sFileName For Input As #nFree
　　　　　　' ファイルの最終行を読み終わるまでループ
　　　　　　Do While Not EOF(1)
　　　　　　　　' ' 出力する行位置をカウントアップ
　　　　　　　　cnLines = cnLines + 1
　　　　　　　　' ' テキストデータを一行ずつ変数に読み込む
　　　　　　　　Line Input #nFree, sTempLine
　　　　　　　　' ' 読み込んだテキストデータを一行ずつセルに出力
　　　　　　　　Cells(cnLines, 1) = sTempLine
　　　　　　Loop
　　　　　　' ' 開いたファイルを閉じる
　　　　　　Close #nFree
　　　　Else　　' 存在しないなら
　　　　　　' ' 見つからないファイルがあった場合の告知用文字列
　　　　　　sMsg = sMsg & vbLf & sFileName
　　　　End If

　　Next i

　　' ' アプリケーションの描画更新再開
　　Application.ScreenUpdating = True

　　If sMsg <> "" Then MsgBox Mid$(sMsg, 2) & vbLf & vbLf & "↑　見つかりません。", vbInformation
End Sub

回答No.1

cj_mover

' ' 標準モジュール専用
Sub Re8257248a()
　　Const fFolderPath = "C:\Users\Owner\Documents"　　' フォルダ名
　　Dim v As Variant　　' ループ用（値配列の要素）
　　Dim oFSO As Object　　' Scripting.FileSystemObject
　　Dim oFolder As Object　　' Scripting.Folder
　　Dim oFile As Object　　' Scripting.File
　　Dim oDtObj As Object　　' MSForms.DataObject
　　Dim sBuf As String　　' テキストデータを流し込む変数
　　Dim cn As Long　　' フォルダ内のテキストファイルの数

　' ' FSO（ファイルシステムオブジェクト）
　　Set oFSO = CreateObject("Scripting.FileSystemObject")　　' New Scripting.FileSystemObject
　' ' FSOで指定フォルダをFolderオブジェクトとして取得
　　Set oFolder = oFSO.GetFolder(fFolderPath)

　' ' シート3を選択。シート名要指定
　　Sheets("Sheet3").Select
　' ' Ａ列の値を消去
　　Columns(1).ClearContents

　' ' 指定フォルダ内のFileオブジェクトすべてをループ
　　For Each oFile In oFolder.Files
　　　' ' テキストファイルならば
　　　　If oFile.Type = "テキスト ドキュメント" Then
　　　　　' ' テキストファイル数をカウントアップ
　　　　　　cn = cn + 1
　　　　　' ' Ａ列cn行めのセルに、ファイル名を出力
　　　　　　Cells(cn, 1) = oFile.Name
　　　　End If
　　Next

　' ' ファイル名を出力したセル範囲
　　With Range("A1:A" & cn)
　　　' ' 昇順で並び替え
　　　　.Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
　　　' ' ファイル名を出力したセル範囲の値配列すべてをループ
　　　　For Each v In .Value
　　　　　' ' 指定フォルダから、ファイル名に応じたテキスト全文をバッファに流し込む
　　　　　　sBuf = sBuf & vbCrLf & oFolder.Files(CStr(v)).OpenAsTextStream.ReadAll
　　　　Next
　　　' ' セル範囲、消去
　　　　.ClearContents
　　End With

　' ' クリップボードに文字列を渡すためのデータオブジェクト
　　Set oDtObj = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")　　' New MSForms.DataObject
　' ' DataObject経由でクリップボードへテキスト出力
　　With oDtObj
　　　　.SetText Mid$(sBuf, 3)
　　　　.PutInClipboard
　　End With

　' ' クリップボードからセル範囲へ貼付け
　　Cells(1).PasteSpecial

　　Set oFSO = Nothing:　　Set oFolder = Nothing:　　Set oDtObj = Nothing
End Sub