teratail
回答率
85.33%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問VBAfフォルダの複数ファイル内の複数シートを一括取込み

編集履歴

質問編集履歴

1

トラブルの要因のコードがそもそも間違っていました。

2025/02/05 22:15

投稿

hajihaji
hajihaji

スコア20

test CHANGED
@@ -1 +1 @@
1
- VBA大量シート抽出時のデータ重複
1
+ VBAfフォルダの複数ファイル内の複数シートを一括取込み
test CHANGED
@@ -2,8 +2,8 @@
2
2
  大量のエクセルシートをすべて抽出。
3
3
 
4
4
  ### 発生している問題・分からないこと
5
- VBAで180枚のシートからデータを抽出すると同じデータを重複して抽出されてしまうのですが原因がわかりません。
5
+ VBAでフォルダのなかにある複数ファイル内から複数シートを一括取込むと同じシートが重複して抽出されてしまうのですが原因がわかりません。
6
- シート名はすべて違う名前がふられています。どうも２度ほど処理を繰り返しているようです。
6
+ 取り込む際重複したシート名には違う名前がふられていきますがどうもシートによっては２度ほど処理を繰り返しているようです。
7
7
  アドバイスをいただけますと幸いです。
8
8
 
9
9
 
@@ -12,48 +12,33 @@
12
12
 
13
13
  ```
14
14
  On Error Resume Next
15
+ Dim FileName As String
15
- Dim s, key As Variant
16
+ Dim IsBookOpen As Boolean
16
- Dim sh1, sh2 As Worksheet
17
+ Dim OpenBook As Workbook
17
- Dim dicT As Object
18
- Dim i, n, R1, R2, R3 As Long
18
+ Dim ShCount As Long
19
+ With CreateObject("WScript.Shell")
20
+ .CurrentDirectory = "C:\Users\----\Desktop\取込用"
21
+ End With
22
+ FileName = Dir("*.xlsx")
19
- Application.ScreenUpdating = False '画面描画を停止
23
+ Do While FileName <> ""
24
+ If FileName <> ThisWorkbook.Name Then
25
+ IsBookOpen = False
26
+ For Each OpenBook In Workbooks
20
- Application.EnableEvents = False 'イベントを抑止
27
+ If OpenBook.Name = FileName Then
21
- Application.DisplayAlerts = False '確認メッセージを抑止
22
- Application.Calculation = xlCalculationManual
28
+ IsBookOpen = True
29
+ Exit For
30
+ End If
31
+ Next
23
32
 
24
- Set dicT = CreateObject("Scripting.Dictionary")
25
- Set sh1 = Worksheets("注文書T")
33
+ If IsBookOpen = False Then
26
- Set sh2 = Worksheets("不明")
27
- Set sh3 = Worksheets("BK")
28
- For Each s In ThisWorkbook.Worksheets
34
+ ShCount = ThisWorkbook.Worksheets.Count
29
- R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
35
+ Workbooks.Open (FileName), UpdateLinks:=1
30
- R2 = s.Cells(s.Rows.Count, "A").End(xlUp).Row
36
+ Worksheets.Copy after:=ThisWorkbook.Worksheets(ShCount)
31
-
32
- For lrow = 2 To R1
33
- key = sh1.Cells(lrow, "Q").Value
34
- dicT(key) = True
35
- Next
36
- n = R1 + 1
37
- For i = 2 To R2
38
- If s.Name <> "注文書T" And s.Name <> "不明" And s.Name <> "BK" Then
39
-
40
- ' If s.Cells(i, "G").Value <> "" Then
41
- ' key = s.Cells(i, "Q").Value
37
+ Workbooks(FileName).Close savechanges:=False
42
- ' If dicT.Exists(key) = False Then
43
- sh1.Cells(n, "A") = s.Cells(i, "A")
44
- sh1.Cells(n, "B") = s.Cells(i, "B")
45
- sh1.Cells(n, "C") = s.Cells(i, "C")
46
-
47
- End If
38
+ End If
48
- n = n + 1
49
- ' End If
39
+ End If
50
- Next i
40
+ FileName = Dir()
51
- Next
41
+ Loop
52
- Application.StatusBar = False 'ステータスバーを消す
53
- Application.Calculation = xlCalculationAutomatic '計算を自動に
54
- Application.DisplayAlerts = True '確認メッセージを開始
55
- Application.EnableEvents = True 'イベントを開始
56
- Application.ScreenUpdating = True '画面描画を開始
57
42
  ```
58
43
 
59
44
  ### 試したこと・調べたこと
VBAマクロExcel