teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問エクセルVBAでのブック間ペーストができない

編集履歴

回答編集履歴

5

コード修正

2020/04/09 13:04

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -34,13 +34,15 @@
34
34
 
35
35
 
36
36
 
37
+ Const FolderPath = "C:\Desktop\集計\"
38
+
37
- Filename = Dir("C:\Desktop\集計*.xlsx")
39
+ Filename = Dir(FolderPath & "*.xlsx")
38
40
 
39
41
 
40
42
 
41
43
  Do While Filename <> ""
42
44
 
43
- Set OpenBook = Workbooks.Open(Filename)
45
+ Set OpenBook = Workbooks.Open(FolderPath & Filename)
44
46
 
45
47
 
46
48
 

4

コード修正

2020/04/09 13:04

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -40,7 +40,7 @@
40
40
 
41
41
  Do While Filename <> ""
42
42
 
43
- Set OpenBook = Workbooks.Open(Filename, UpdateLinks:=1)
43
+ Set OpenBook = Workbooks.Open(Filename)
44
44
 
45
45
 
46
46
 

3

コード修正

2020/04/09 12:17

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -28,9 +28,9 @@
28
28
 
29
29
  Dim OpenBook As Workbook
30
30
 
31
- Dim PassteCell As Range
31
+ Dim PasteCell As Range
32
32
 
33
- Set PassteCell = ThisWorkbook.Worksheets("10月").Cells(2, 3)
33
+ Set PasteCell = ThisWorkbook.Worksheets("10月").Cells(2, 3)
34
34
 
35
35
 
36
36
 
@@ -50,7 +50,7 @@
50
50
 
51
51
 
52
52
 
53
- Set PassteCell = PassteCell.Offset(1) '次のセル
53
+ Set PasteCell = PasteCell.Offset(1) '次のセル
54
54
 
55
55
  Filename = Dir()
56
56
 

2

コード修正

2020/04/09 11:55

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -24,11 +24,13 @@
24
24
 
25
25
  Sub 集計()
26
26
 
27
-
28
-
29
27
  Dim Filename As String
30
28
 
31
29
  Dim OpenBook As Workbook
30
+
31
+ Dim PassteCell As Range
32
+
33
+ Set PassteCell = ThisWorkbook.Worksheets("10月").Cells(2, 3)
32
34
 
33
35
 
34
36
 
@@ -42,13 +44,13 @@
42
44
 
43
45
 
44
46
 
45
- ThisWorkbook.Worksheets("10月").Cells(2, 3).Value _
47
+ PassteCell.Value = OpenBook.Worksheets("10月").Range("G1").Value
46
48
 
47
- = OpenBook.Worksheets("10月").Range("G1").Value
48
-
49
- OpenBook.Close SaveChanges:=False 'True
49
+ OpenBook.Close SaveChanges:=False
50
50
 
51
51
 
52
+
53
+ Set PassteCell = PassteCell.Offset(1) '次のセル
52
54
 
53
55
  Filename = Dir()
54
56
 

1

コード追記

2020/04/09 11:09

投稿

hatena19
hatena19

スコア34075

test CHANGED
@@ -11,3 +11,51 @@
11
11
  `Cells(2,3).PasteSpecial Paste:=xlPasteValues`
12
12
 
13
13
  としてください。
14
+
15
+
16
+
17
+ ---
18
+
19
+ 蛇足ですが、使用していない変数があったり、無駄な処理が多いのが気になるので、リファクタリングしてみました。
20
+
21
+
22
+
23
+ ```vba
24
+
25
+ Sub 集計()
26
+
27
+
28
+
29
+ Dim Filename As String
30
+
31
+ Dim OpenBook As Workbook
32
+
33
+
34
+
35
+ Filename = Dir("C:\Desktop\集計*.xlsx")
36
+
37
+
38
+
39
+ Do While Filename <> ""
40
+
41
+ Set OpenBook = Workbooks.Open(Filename, UpdateLinks:=1)
42
+
43
+
44
+
45
+ ThisWorkbook.Worksheets("10月").Cells(2, 3).Value _
46
+
47
+ = OpenBook.Worksheets("10月").Range("G1").Value
48
+
49
+ OpenBook.Close SaveChanges:=False 'True
50
+
51
+
52
+
53
+ Filename = Dir()
54
+
55
+ Loop
56
+
57
+
58
+
59
+ End Sub
60
+
61
+ ```