複数のテキストファイル(.txt)を一度に読み込んで、ある条件に従って
1つのシート(Sheet1)の特定のセルに表示するコードです。
※長くなってしまったので、続きを、このページ下部のコメント欄に書かせていただきます。
よろしくおねがいします。
運用面から少し仕様を変更してみました。
実際の要望に即さない場合は、コメント下さい。
まず管理EXCELがあるフォルダ下に「リスト更新」、「リスト更新済」の二つのフォルダをおきます。
変更する項目名+".txt" のファイルを、「リスト更新」フォルダ下に置きます。
マクロを実行すると、「リスト更新」下のファイルをスキャンし、該当列がない場合は警告を表示して終了します。
終了せずに処理を継続したい場合は、マクロ中の★の行を削除してください。
列の更新を順次実行し、処理が終わった txt ファイルは「リスト更新済」に移動します。
Option Explicit '// コマンドボタン処理 '//----------------------------------- Private Sub CommandButton1_Click() Const updateSourceFolder = "リスト更新" Const updateResultFolder = "リスト更新済" Dim fso Set fso = CreateObject("Scripting.FileSystemObject") Dim objDic Set objDic = CreateObject("Scripting.Dictionary") Dim msg As String msg = "" '// ファイルの確認 Dim colName As String Dim colRange As Range Dim file As Object For Each file In fso.GetFolder(ThisWorkbook.Path & "\" & updateSourceFolder).Files colName = Replace(file.Name, ".txt", "") Set colRange = Rows(2).Find(colName, lookat:=xlWhole) If colRange Is Nothing Then msg = msg & colName & " " Else objDic.Add colName, file.Path End If Next If msg <> "" Then MsgBox "エクセルに [" & msg & "]のデータが存在しません!" Exit Sub '// ★該当しないファイルがあったら中止:継続の場合はこの行を削除 End If '// ファイルの読込み処理 Dim r As Range Dim ar For Each r In Rows(2).Cells If r.Value <> "" Then If objDic.exists(r.Value) = True Then If MsgBox(r.Value & "のデータを上書きしてもいいですか?", vbYesNo, "更新確認") = vbYes Then r.Offset(1, 0).Resize(Rows.Count - 2, 1).ClearContents ar = Split(fso.OpenTextFile(objDic.Item(r.Value)).ReadAll(), vbNewLine) r.Offset(1, 0).Resize(UBound(ar) + 1, 1) = Application.Transpose(ar) MsgBox r.Value & "のデータを上書きしました!" fso.GetFile(objDic.Item(r.Value)).Move ThisWorkbook.Path & "\" & updateResultFolder & "\" End If End If End If Next End Sub
仕様が異なる場合等は、コメント下さい。
Mookさんへ
ご回答ほんとうにありがとうございます。
すごい便利!の一言です。
もちろんエラーもありません。
あまりに使いやすいので、びっくりしました。
フォルダのこういう考え方があるんですね!
毎回、希望通りの仕様にしていただき感謝しています。