teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問vbaで複数のテキストファイルを読み込んで同じ処理を行い、ファイル名に合わせたシートに貼り付けたいです。

編集履歴

回答編集履歴

1

修正

2022/01/05 00:34

投稿

jinoji
jinoji

スコア4592

test CHANGED
@@ -1,62 +1,62 @@
1
- たとえばこんな感じでどうでしょうか。
1
+ フォルダ内のファイルを順に処理するよう修正してみました。
2
+
3
+ （ファイル番号が２桁固定の前提で書いているので、そうでないなら直してください。）
2
4
 
3
5
 
4
6
 
5
7
  ```VBA
6
8
 
9
+ Option Explicit
10
+
11
+
12
+
7
- Sub 抽出123()
13
+ Sub 抽出()
8
14
 
9
15
 
10
16
 
11
- Call 抽出("01")
17
+ Dim fso As Object
12
18
 
13
- Call 抽出("02")
19
+ Dim f As Object
14
20
 
15
- Call 抽出("03")
21
+ Dim fileNo As String
16
22
 
23
+ Dim sBuf As String
17
24
 
25
+ Dim ws As Worksheet
26
+
27
+
28
+
29
+ Set fso = CreateObject("Scripting.FileSystemObject")
30
+
31
+ For Each f In fso.GetFolder(ThisWorkbook.Path).Files
32
+
33
+ If f.Name Like "ファイル名_*" Then
34
+
35
+ With f.OpenAsTextStream
36
+
37
+ sBuf = .ReadAll
38
+
39
+ .Close
40
+
41
+ End With
42
+
43
+ fileNo = Mid(f.Name, 7, 2)
44
+
45
+ Set ws = ThisWorkbook.Worksheets(fileNo)
46
+
47
+ Call シート書き込み(ws, sBuf)
48
+
49
+ End If
50
+
51
+ Next
52
+
53
+
18
54
 
19
55
  End Sub
20
56
 
21
57
 
22
58
 
23
- Sub 抽出(fileNo As String)
59
+ Sub シート書き込み(ws As Worksheet, sBuf As String)
24
-
25
-
26
-
27
- Dim fileName As String
28
-
29
- fileName = "ファイル名_" & fileNo
30
-
31
-
32
-
33
- Dim ws As Worksheet
34
-
35
- Set ws = ThisWorkbook.Worksheets(fileNo)
36
-
37
-
38
-
39
- Application.ScreenUpdating = False
40
-
41
- Dim fso As Object
42
-
43
- Set fso = CreateObject("Scripting.FileSystemObject")
44
-
45
- Dim path
46
-
47
- path = ThisWorkbook.path 'カレントディレクトリを取得
48
-
49
- Dim sBuf As String
50
-
51
- 'テキストのフルパスを指定
52
-
53
- With fso.GetFile(FilePath:=path & "\" & fileName).OpenAsTextStream
54
-
55
- sBuf = .ReadAll
56
-
57
- .Close
58
-
59
- End With
60
60
 
61
61
 
62
62