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

編集履歴

回答編集履歴

5

コード修正

2020/04/09 13:04

投稿

hatena19
hatena19

スコア34367

answer CHANGED
@@ -16,10 +16,11 @@
16
16
  Dim PasteCell As Range
17
17
  Set PasteCell = ThisWorkbook.Worksheets("10月").Cells(2, 3)
18
18
 
19
+ Const FolderPath = "C:\Desktop\集計\"
19
- Filename = Dir("C:\Desktop\集計*.xlsx")
20
+ Filename = Dir(FolderPath & "*.xlsx")
20
21
 
21
22
  Do While Filename <> ""
22
- Set OpenBook = Workbooks.Open(Filename)
23
+ Set OpenBook = Workbooks.Open(FolderPath & Filename)
23
24
 
24
25
  PassteCell.Value = OpenBook.Worksheets("10月").Range("G1").Value
25
26
  OpenBook.Close SaveChanges:=False

4

コード修正

2020/04/09 13:04

投稿

hatena19
hatena19

スコア34367

answer CHANGED
@@ -19,7 +19,7 @@
19
19
  Filename = Dir("C:\Desktop\集計*.xlsx")
20
20
 
21
21
  Do While Filename <> ""
22
- Set OpenBook = Workbooks.Open(Filename, UpdateLinks:=1)
22
+ Set OpenBook = Workbooks.Open(Filename)
23
23
 
24
24
  PassteCell.Value = OpenBook.Worksheets("10月").Range("G1").Value
25
25
  OpenBook.Close SaveChanges:=False

3

コード修正

2020/04/09 12:17

投稿

hatena19
hatena19

スコア34367

answer CHANGED
@@ -13,8 +13,8 @@
13
13
  Sub 集計()
14
14
  Dim Filename As String
15
15
  Dim OpenBook As Workbook
16
- Dim PassteCell As Range
16
+ Dim PasteCell As Range
17
- Set PassteCell = ThisWorkbook.Worksheets("10月").Cells(2, 3)
17
+ Set PasteCell = ThisWorkbook.Worksheets("10月").Cells(2, 3)
18
18
 
19
19
  Filename = Dir("C:\Desktop\集計*.xlsx")
20
20
 
@@ -24,7 +24,7 @@
24
24
  PassteCell.Value = OpenBook.Worksheets("10月").Range("G1").Value
25
25
  OpenBook.Close SaveChanges:=False
26
26
 
27
- Set PassteCell = PassteCell.Offset(1) '次のセル
27
+ Set PasteCell = PasteCell.Offset(1) '次のセル
28
28
  Filename = Dir()
29
29
  Loop
30
30
 

2

コード修正

2020/04/09 11:55

投稿

hatena19
hatena19

スコア34367

answer CHANGED
@@ -11,19 +11,20 @@
11
11
 
12
12
  ```vba
13
13
  Sub 集計()
14
-
15
14
  Dim Filename As String
16
15
  Dim OpenBook As Workbook
16
+ Dim PassteCell As Range
17
+ Set PassteCell = ThisWorkbook.Worksheets("10月").Cells(2, 3)
17
18
 
18
19
  Filename = Dir("C:\Desktop\集計*.xlsx")
19
20
 
20
21
  Do While Filename <> ""
21
22
  Set OpenBook = Workbooks.Open(Filename, UpdateLinks:=1)
22
23
 
23
- ThisWorkbook.Worksheets("10月").Cells(2, 3).Value _
24
- = OpenBook.Worksheets("10月").Range("G1").Value
24
+ PassteCell.Value = OpenBook.Worksheets("10月").Range("G1").Value
25
- OpenBook.Close SaveChanges:=False 'True
25
+ OpenBook.Close SaveChanges:=False
26
26
 
27
+ Set PassteCell = PassteCell.Offset(1) '次のセル
27
28
  Filename = Dir()
28
29
  Loop
29
30
 

1

コード追記

2020/04/09 11:09

投稿

hatena19
hatena19

スコア34367

answer CHANGED
@@ -4,4 +4,28 @@
4
4
  `Range("C2").PasteSpecial Paste:=xlPasteValues`
5
5
  とするか、
6
6
  `Cells(2,3).PasteSpecial Paste:=xlPasteValues`
7
- としてください。
7
+ としてください。
8
+
9
+ ---
10
+ 蛇足ですが、使用していない変数があったり、無駄な処理が多いのが気になるので、リファクタリングしてみました。
11
+
12
+ ```vba
13
+ Sub 集計()
14
+
15
+ Dim Filename As String
16
+ Dim OpenBook As Workbook
17
+
18
+ Filename = Dir("C:\Desktop\集計*.xlsx")
19
+
20
+ Do While Filename <> ""
21
+ Set OpenBook = Workbooks.Open(Filename, UpdateLinks:=1)
22
+
23
+ ThisWorkbook.Worksheets("10月").Cells(2, 3).Value _
24
+ = OpenBook.Worksheets("10月").Range("G1").Value
25
+ OpenBook.Close SaveChanges:=False 'True
26
+
27
+ Filename = Dir()
28
+ Loop
29
+
30
+ End Sub
31
+ ```