vbaで複数のテキストファイルを読み込んで同じ処理を行い、ファイル名に合わせたシートに貼り付けたいです。

前提・実現したいこと

テキスト形式のファイルの指定の単語から始まる行を取得、カンマ区切りで一時的に計算用シートに貼り付け、指定の単語を削除、昇順に並べ替え。
残った２列を別のシートに貼り付ける処理を行っています。
ファイル名が「～_01」のものは01のシートに、「～_03」のものは03のシートに貼り付けたいと考えています。
どこをどのように変更すればよいでしょうか。
独学の為分かりにくい部分もあるかと思いますが、よろしくお願いします。

該当のソースコード

vba
1Option Explicit
2
3Sub 抽出01()
4
5    Application.ScreenUpdating = False
6    Dim fso As Object
7    Set fso = CreateObject("Scripting.FileSystemObject")
8    Dim path
9    path = ThisWorkbook.path 'カレントディレクトリを取得
10    Dim sBuf As String
11    'テキストのフルパスを指定
12    With fso.GetFile(FilePath:=path & "\ファイル名_01").OpenAsTextStream
13        sBuf = .ReadAll
14        .Close
15    End With
16
17    Dim k As Long: k = 0
18    Dim p1 As Long: p1 = 1
19    Dim p2 As Long
20    Dim tmpBuf As String
21    Dim ary()
22    Do
23        p1 = InStr(p1, sBuf, "指定単語")
24        If p1 = 0 Then Exit Do
25        p2 = InStr(p1, sBuf, vbLf)
26        If p2 = 0 Then Exit Do
27        tmpBuf = Mid(sBuf, p1, p2 - p1)
28        p1 = p2
29
30        ReDim Preserve ary(k)
31        ary(k) = tmpBuf
32        k = k + 1
33    Loop
34
35    Range("A2").Resize(UBound(ary) + 1).Value = WorksheetFunction.Transpose(ary)
36    Application.ScreenUpdating = True
37    
38        Dim myStr '引数１となる文字列
39    Dim Pref() As String  '結果を格納する配列
40    Dim i As Long   'セル書き込み時のカウンタ変数
41    Dim j As Long
42    
43 For j = 1 To Cells(Rows.Count, 1).End(xlUp).Row
44    myStr = Cells(j, 1)
45 
46    Pref = Split(myStr, ",") 'Split関数実行
47
48 
49'セルに書き写します
50    For i = 1 To UBound(Pref) 'カウンタ変数iは0から3まで
51        Cells(j, i + 1).Value = Pref(i) 'Cellsの行インデックスに注意
52    Next i
53
54Next j
55    
56End Sub
57Sub unl転写01()
58    Dim endRow
59    endRow = Worksheets("計算用").Cells(Rows.Count, 1).End(xlUp).Row
60    Range(Cells(2, 2), Cells(endRow, 3)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
61    SortMethod:=xlPinYin
62    
63    Worksheets("計算用").Range(Cells(2, 2), Cells(endRow, 3)).Cut Destination:=Worksheets("01").Range("A2")
64    Worksheets("計算用").Activate
65    Range(Cells(2, 1), Cells(endRow, 3)).ClearContents
66
67End Sub
68

試したこと

動きはするのですが、今の状態だと01、02、03とべた書きでコードを書かなければいけません。

補足情報（FW/ツールのバージョンなど）

ここにより詳細な情報を記載してください。

行動規範の内容に同意します

回答2件

フォルダ内のファイルを順に処理するよう修正してみました。
（ファイル番号が２桁固定の前提で書いているので、そうでないなら直してください。）

VBA
1Option Explicit
2
3Sub 抽出()
4    
5    Dim fso As Object
6    Dim f As Object
7    Dim fileNo As String
8    Dim sBuf As String
9    Dim ws As Worksheet
10    
11    Set fso = CreateObject("Scripting.FileSystemObject")
12    For Each f In fso.GetFolder(ThisWorkbook.Path).Files
13        If f.Name Like "ファイル名_*" Then
14            With f.OpenAsTextStream
15                sBuf = .ReadAll
16                .Close
17            End With
18            fileNo = Mid(f.Name, 7, 2)
19            Set ws = ThisWorkbook.Worksheets(fileNo)
20            Call シート書き込み(ws, sBuf)
21        End If
22    Next
23 
24End Sub
25
26Sub シート書き込み(ws As Worksheet, sBuf As String)
27
28    Dim k As Long: k = 0
29    Dim p1 As Long: p1 = 1
30    Dim p2 As Long
31    Dim tmpBuf As String
32    Dim ary()
33    Do
34        p1 = InStr(p1, sBuf, "指定単語")
35        If p1 = 0 Then Exit Do
36        p2 = InStr(p1, sBuf, vbLf)
37        If p2 = 0 Then Exit Do
38        tmpBuf = Mid(sBuf, p1, p2 - p1)
39        p1 = p2
40
41        ReDim Preserve ary(k)
42        ary(k) = tmpBuf
43        k = k + 1
44    Loop
45
46    ws.Range("A2").Resize(UBound(ary) + 1).Value = WorksheetFunction.Transpose(ary)
47    Application.ScreenUpdating = True
48
49        Dim myStr '引数１となる文字列
50    Dim Pref() As String  '結果を格納する配列
51    Dim i As Long   'セル書き込み時のカウンタ変数
52    Dim j As Long
53
54    For j = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
55        myStr = ws.Cells(j, 1)
56        
57        Pref = Split(myStr, ",") 'Split関数実行
58        
59        
60        'セルに書き写します
61        For i = 1 To UBound(Pref) 'カウンタ変数iは0から3まで
62            ws.Cells(j, i + 1).Value = Pref(i) 'Cellsの行インデックスに注意
63        Next i
64    
65    Next j
66
67End Sub
68

投稿2022/01/04 06:04

編集2022/01/05 00:34

jinoji

総合スコア4585

kanata0214

2022/01/04 07:04

ありがとうございます！重ねて質問なのですが実行するときは「抽出」のほうを実行すればよいのでしょうか。また、01～05の時もあれば、01～10、01～05と99という場合があるのですが、対応するためにはどこを変更すればよいでしょうか。お手数をおかけしますが、よろしくお願いします。

jinoji

2022/01/04 09:21

＞01～05の時もあれば、01～10、01～05と99という場合があるそれはどうやって判断できますか？たとえばExcelのどこかのシートに対象の一覧が書いてあるとか、対象フォルダの中にあるファイルを全て処理するとか。それによって、書くべきコードが決まってくると思います。

kanata0214

2022/01/04 11:38

返信ありがとうございます。対象フォルダに入っている「ファイル名_数字」のファイル全てが対象です。フォルダの中には ①このExcel ②抽出対象ファイル（複数）があります。

kanata0214

2022/01/05 07:48

教えて頂いたコード参考にしながら、どうにかコード完成しました！アドバイス頂きありがとうございました！

行動規範の内容に同意します

自己解決

ファイル名の取得が教えて頂いた方法でもうまくいかなかったのでExcelのページに一旦出力する形で実行しました。

vba
1Option Explicit
2Sub ファイル一覧取得()
3
4    Dim path
5     path = ThisWorkbook.path  'カレントディレクトリを取得
6    Dim i As Long
7    Dim sFileName As String
8    Worksheets("メイン").Activate
9    With Worksheets("メイン")
10     sFileName = Dir(path & "\ファイル名_*")
11     i = 21
12     Do While sFileName <> "" 'ファイルが無くなるまで取得
13       Cells(i, 1) = sFileName
14       i = i + 1
15       sFileName = Dir()
16     Loop
17    End With
18
19End Sub
20Sub 抽出テーブル()
21
22    Application.ScreenUpdating = False
23    Dim FSO As Object
24    Set FSO = CreateObject("Scripting.FileSystemObject")
25    Dim path
26    path = ThisWorkbook.path 'カレントディレクトリを取得
27    Dim sBuf As String
28    Dim cnt
29    Dim filename
30    Dim fileno
31    Worksheets("メイン").Activate
32    For cnt = 21 To Cells(Rows.count, 1).End(xlUp).Row
33    Worksheets("メイン").Activate
34     filename = Cells(cnt, 1).Value
35     fileno = Mid(filename, 9, 2)
36
37    'テキストのフルパスを指定
38'    On Error GoTo Label01
39
40     With FSO.GetFile(path & "\" & filename).OpenAsTextStream
41        sBuf = .ReadAll
42        .Close
43     End With
44
45     Dim k As Long: k = 0
46     Dim p1 As Long: p1 = 1
47     Dim p2 As Long
48     Dim tmpBuf As String
49     Dim ary()
50      Do
51        p1 = InStr(p1, sBuf, "指定単語")
52        If p1 = 0 Then Exit Do
53        p2 = InStr(p1, sBuf, vbLf)
54        If p2 = 0 Then Exit Do
55        tmpBuf = Mid(sBuf, p1, p2 - p1)
56        p1 = p2
57
58        ReDim Preserve ary(k)
59        ary(k) = tmpBuf
60        k = k + 1
61      Loop
62      
63    Worksheets("計算用").Activate
64    Range("A2").Resize(UBound(ary) + 1).Value = WorksheetFunction.Transpose(ary)
65    Application.ScreenUpdating = True
66    
67        Dim myStr '引数１となる文字列
68    Dim Pref() As String  '結果を格納する配列
69    Dim i As Long   'セル書き込み時のカウンタ変数
70    Dim j As Long
71    
72 For j = 1 To Cells(Rows.count, 1).End(xlUp).Row
73    myStr = Cells(j, 1)
74 
75    Pref = Split(myStr, ",") 'Split関数実行
76
77 
78'セルに書き写します
79    For i = 1 To UBound(Pref) 'カウンタ変数iは0から3まで
80        Cells(j, i + 1).Value = Pref(i) 'Cellsの行インデックスに注意
81    Next i
82
83Next j
84    
85    Dim endRow
86    endRow = Worksheets("計算用").Cells(Rows.count, 1).End(xlUp).Row
87    Range(Cells(2, 2), Cells(endRow, 3)).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
88    SortMethod:=xlPinYin
89    
90    Worksheets("計算用").Range(Cells(2, 2), Cells(endRow, 3)).Cut Destination:=Worksheets(fileno).Range("A2")
91    Worksheets("計算用").Activate
92    Range(Cells(2, 1), Cells(endRow, 3)).ClearContents
93 Next cnt
94     Worksheets("メイン").Activate
95    MsgBox "終了しました"
96Exit Sub
97     
98Label01:
99  MsgBox ("ファイルがありません")
100End Sub
101