teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップに関する質問Excelに画像一括挿入(貼付)を自動で行いたい

編集履歴

質問編集履歴

11

初心者マークつけた

2021/09/16 14:23

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -12,7 +12,7 @@
12
12
 
13
13
  ### 事前設定・前提条件
14
14
 
15
- ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。
15
+ ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。　
16
16
 
17
17
  ・同じくCドライブ内に今回対象のExcelファイルも格納済。
18
18
 

10

現在のコード・問題を追記、並べ替え済

2021/09/16 14:22

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -32,29 +32,9 @@
32
32
 
33
33
  （最新の内容だと）
34
34
 
35
- 実行時エラー'9'
36
-
37
-
38
-
39
- エラーに関しては以下の箇所が黄色マーカーで「インデックスが有効範囲にありません」と表示されています。
40
-
41
- Worksheets(クリエイティブ).Shapes.AddPicture _
42
-
43
- 　Filename:=myName, _
44
-
45
- LinkToFile:=False, _
46
-
47
- SaveWithDocument:=True, _
48
-
49
- LockAspectRatio:=msoTrue, _
50
-
51
- Height:=49.5
52
-
53
-
54
-
55
- 前部分の構文との組合せでそうなっているのかわかりません。
35
+ 画像パスの1枚目の画像が指定のシート＆開始セルに貼り付けられたが、
56
-
36
+
57
- 一番最初の「Sub 画像一括挿入（）」の箇所は黄色マーカーが引かれていて左から➡も表示されています。
37
+ 10枚以上同じ画像が同じセルに元のサイズで貼り付けられた状態
58
38
 
59
39
  ```
60
40
 
@@ -64,12 +44,204 @@
64
44
 
65
45
 
66
46
 
67
- ①最初に試したコード
47
+ ④修正して現在のコード
68
48
 
69
49
  ```
70
50
 
71
51
  Sub 画像一括挿入()
72
52
 
53
+ Dim shpPic As Shape
54
+
55
+ Dim myNo As Long
56
+
57
+ Dim i As Long
58
+
59
+ Dim myRow As Long
60
+
61
+ Dim myName As String
62
+
63
+ Dim myDataCnt As Long
64
+
65
+
66
+
67
+ myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
68
+
69
+ myNo = 1
70
+
71
+ myRow = 2
72
+
73
+
74
+
75
+ Worksheets("クリエイティブ").Select
76
+
77
+ Dim shp As Object
78
+
79
+ For myNo = 1 To myDataCnt
80
+
81
+ myName = Worksheets("CRデータ").Cells(2, 1).Value
82
+
83
+ With Worksheets("クリエイティブ").Shapes.AddPicture _
84
+
85
+ (Filename:=myName, _
86
+
87
+ LinkToFile:=False, _
88
+
89
+ SaveWithDocument:=True, _
90
+
91
+ Left:=Range("D6").Left, _
92
+
93
+ Top:=Range("D6").Top, _
94
+
95
+ Height:=-1, _
96
+
97
+ Width:=-1)
98
+
99
+ LockAspectRatio = msoTrue
100
+
101
+ myRow = myRow + 1
102
+
103
+ End With
104
+
105
+ Next
106
+
107
+ End Sub
108
+
109
+ ```
110
+
111
+
112
+
113
+ ~~③ご回答頂き修正したコード(その1）~~
114
+
115
+ ```
116
+
117
+ Sub 画像一括挿入()
118
+
119
+ Dim shpPic As Shape
120
+
121
+ Dim myNo As Long
122
+
123
+ Dim i As Long
124
+
125
+ Dim myRow As Long
126
+
127
+ Dim myName As String
128
+
129
+
130
+
131
+ myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
132
+
133
+ myNo = 1
134
+
135
+ myRow = 2
136
+
137
+
138
+
139
+ Worksheets("クリエイティブ").Select
140
+
141
+ Do Until myNo > myDataCnt
142
+
143
+ myName = Worksheets("CRデータ").Cells(myNo, 1).Value
144
+
145
+
146
+
147
+ 　　　　　　 Cells(myRow, 2).Select
148
+
149
+ Worksheets(クリエイティブ).Shapes.AddPicture _
150
+
151
+ 　Filename:=myName, _
152
+
153
+ LinkToFile:=False, _
154
+
155
+ SaveWithDocument:=True, _
156
+
157
+ LockAspectRatio:=msoTrue, _
158
+
159
+ Height:=49.5
160
+
161
+ With shp
162
+
163
+ .Left = Range("D6").Left
164
+
165
+ .Top = Range("D6").Top
166
+
167
+ End With
168
+
169
+ Loop
170
+
171
+
172
+
173
+ End Sub
174
+
175
+ ```
176
+
177
+ ~~②書き換えを試みたコード~~
178
+
179
+ ```
180
+
181
+ Sub 画像一括挿入()
182
+
183
+ Dim shpPic As Shape
184
+
185
+ Dim myNo As Long
186
+
187
+ Dim i As Long
188
+
189
+ Dim myRow As Long
190
+
191
+ Dim myName As String
192
+
193
+
194
+
195
+ myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
196
+
197
+ myNo = 1
198
+
199
+ myRow = 2
200
+
201
+
202
+
203
+ Worksheets("クリエイティブ").Select
204
+
205
+ Do Until myNo > myDataCnt
206
+
207
+ myName = Worksheets("CRデータ").Cells(myNo, 1).Value
208
+
209
+
210
+
211
+ Cells(myRow, 2).Select
212
+
213
+ Worksheets(クリエイティブ).Shapes.AddPicture _
214
+
215
+ Filename:=myName, _
216
+
217
+ LinkToFile:=False, _
218
+
219
+ SaveWithDocument:=True, _
220
+
221
+ LockAspectRatio:=mso True, _
222
+
223
+ Height:=49.5
224
+
225
+ With shp
226
+
227
+ .Left = Range("D6").Left
228
+
229
+ .Top = Range("D6").Top
230
+
231
+ End With
232
+
233
+
234
+
235
+ End Sub
236
+
237
+ ```
238
+
239
+ ~~①最初に試したコード~~
240
+
241
+ ```
242
+
243
+ Sub 画像一括挿入()
244
+
73
245
  　　　Dim myDataCnt As Long
74
246
 
75
247
  　　　Dim myNo As Long
@@ -114,147 +286,9 @@
114
286
 
115
287
  　　　
116
288
 
117
- End Sub　
118
-
119
- ```
120
-
121
-
122
-
123
- ②書き換えを試みたコード
124
-
125
- ```
126
-
127
- Sub 画像一括挿入()
128
-
129
- Dim shpPic As Shape
130
-
131
- Dim myNo As Long
132
-
133
- Dim i As Long
134
-
135
- Dim myRow As Long
136
-
137
- Dim myName As String
138
-
139
-
140
-
141
- myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
142
-
143
- myNo = 1
144
-
145
- myRow = 2
146
-
147
-
148
-
149
- Worksheets("クリエイティブ").Select
150
-
151
- Do Until myNo > myDataCnt
152
-
153
- myName = Worksheets("CRデータ").Cells(myNo, 1).Value
154
-
155
-
156
-
157
- Cells(myRow, 2).Select
158
-
159
- Worksheets(クリエイティブ).Shapes.AddPicture _
160
-
161
- Filename:=myName, _
162
-
163
- LinkToFile:=False, _
164
-
165
- SaveWithDocument:=True, _
166
-
167
- LockAspectRatio:=mso True, _
168
-
169
- Height:=49.5
170
-
171
- With shp
172
-
173
- .Left = Range("D6").Left
174
-
175
- .Top = Range("D6").Top
176
-
177
- End With
178
-
179
-
180
-
181
289
  End Sub
182
290
 
183
-
184
-
185
- ```
291
+ ```
186
-
187
- ③ご回答頂き修正したコード(その1）
188
-
189
-
190
-
191
- ```
192
-
193
- Sub 画像一括挿入()
194
-
195
- Dim shpPic As Shape
196
-
197
- Dim myNo As Long
198
-
199
- Dim i As Long
200
-
201
- Dim myRow As Long
202
-
203
- Dim myName As String
204
-
205
-
206
-
207
- myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
208
-
209
- myNo = 1
210
-
211
- myRow = 2
212
-
213
-
214
-
215
- Worksheets("クリエイティブ").Select
216
-
217
- Do Until myNo > myDataCnt
218
-
219
- myName = Worksheets("CRデータ").Cells(myNo, 1).Value
220
-
221
-
222
-
223
- 　　　　　　 Cells(myRow, 2).Select
224
-
225
- Worksheets(クリエイティブ).Shapes.AddPicture _
226
-
227
- 　Filename:=myName, _
228
-
229
- LinkToFile:=False, _
230
-
231
- SaveWithDocument:=True, _
232
-
233
- LockAspectRatio:=msoTrue, _
234
-
235
- Height:=49.5
236
-
237
- With shp
238
-
239
- .Left = Range("D6").Left
240
-
241
- .Top = Range("D6").Top
242
-
243
- End With
244
-
245
- Loop
246
-
247
-
248
-
249
- End Sub
250
-
251
-
252
-
253
- ```
254
-
255
-
256
-
257
- ※VBA/マクロに関しては素人なので色々コードが混在していると思います。。。
258
292
 
259
293
 
260
294
 
@@ -294,6 +328,8 @@
294
328
 
295
329
  →コンパイルエラー続出（構文エラー等）
296
330
 
331
+ →いくつかの修正を経て④のコードが現在の状態
332
+
297
333
  ```
298
334
 
299
335
 

9

実現したいことの追記

2021/09/16 12:52

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -2,6 +2,8 @@
2
2
 
3
3
  複数画像をサイズ調整つき（セル内に収めたい）でExcelに一括挿入で自動貼付できるようにしたいです。
4
4
 
5
+ 現在はOneDrive経由の個人フォルダ内で作成していますが、最終的にはGoogleドライブ上にアップロードするので、その際に互換性やエラーが出ないように進めたいと思っています。
6
+
5
7
 
6
8
 
7
9
  サイズ自動調整の一括画像貼り付けのVBA・マクロが組めたらいいのですが、その辺は知識が足りず、サンプルコードからの修正・応用も上手くいかなかったので、何かいい方法があればお聞きしたいです。

8

補足情報の追記

2021/09/16 12:40

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -300,4 +300,6 @@
300
300
 
301
301
 
302
302
 
303
- ここにより詳細な情報を記載してください。
303
+ マクロ・VBAはこれまで触ったことがありません。全くの素人です。
304
+
305
+ 業務上、効率化するために今回検索して似た記述をベースにして作成してみましたが、全然わからないままエラーで苦戦している状態です。。。

7

画像サイズ及び貼付先のセル概要追記

2021/09/16 09:43

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -8,7 +8,7 @@
8
8
 
9
9
 
10
10
 
11
- ### 事前設定
11
+ ### 事前設定・前提条件
12
12
 
13
13
  ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。
14
14
 
@@ -18,6 +18,8 @@
18
18
 
19
19
  ・シート名「クリエイティブ」が実際に画像を貼り付けるシートであり、D6から画像を貼付ける箇所として設定しています。
20
20
 
21
+ ・画像サイズは複数パターンあるため、（300x300や320x100等）Excelの行の高さを49.5(66ピクセル)、幅は21.88(180ピクセル）で設定しておりますが、縦横比維持したまま貼付けしたいので、一旦高さだけ合っていれば幅は問わず、あとは各セルの中に収まればいいと考えています。
22
+
21
23
 
22
24
 
23
25
  ### 発生している問題・エラーメッセージ

6

事前設定内容を修正

2021/09/16 07:20

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -12,9 +12,11 @@
12
12
 
13
13
  ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。
14
14
 
15
+ ・同じくCドライブ内に今回対象のExcelファイルも格納済。
16
+
15
- ・画像ファイルのパスコピーを貼付したいシートとは別のシート（今回はシート名「CRデータ」）に入力済。（A1は「画像パス」の文言、A2から実際の画像パス）
17
+ ・シート名「CRデータ」に画像ファイルのパスコピーを入力済（A1は「画像パス」の文言、A2から実際の画像パス）
16
-
18
+
17
- ・実際に貼付けるシート（シート名「クリエイティブ」）のD6から画像を貼付ける箇所としています。
19
+ ・シート名「クリエイティブ」が実際に画像を貼り付けるシートであり、D6から画像を貼付ける箇所として設定しています。
18
20
 
19
21
 
20
22
 

5

事前設定内容を追記

2021/09/16 07:12

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -1,14 +1,20 @@
1
- ### 前提・実現したいこと
1
+ ### 実現したいこと
2
-
2
+
3
- 60枚程ある画像を一括でExcelに貼り付けを考えています。
3
+ 複数画像をサイズ調整つき（セル内に収めたい）でExcelに一括挿入で自動貼付できるようにしたいです。
4
4
 
5
5
 
6
6
 
7
7
  サイズ自動調整の一括画像貼り付けのVBA・マクロが組めたらいいのですが、その辺は知識が足りず、サンプルコードからの修正・応用も上手くいかなかったので、何かいい方法があればお聞きしたいです。
8
8
 
9
+
10
+
11
+ ### 事前設定
12
+
9
- 手作業で1枚1枚サイズ調整や貼り付けにならなければやり方は問わずです。
13
+ ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。
14
+
10
-
15
+ ・画像ファイルのパスコピーを貼付したいシートとは別のシート（今回はシート名「CRデータ」）に入力済。（A1は「画像パス」の文言、A2から実際の画像パス）
16
+
11
- どなたか詳しい方よろしくお願いいたします。
17
+ ・実際に貼付けるシート（シート名「クリエイティブ」）のD6から画像を貼付ける箇所としています。
12
18
 
13
19
 
14
20
 

4

コード修正

2021/09/16 07:09

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -28,7 +28,7 @@
28
28
 
29
29
  Worksheets(クリエイティブ).Shapes.AddPicture _
30
30
 
31
- , Filename:=myName, _
31
+ 　Filename:=myName, _
32
32
 
33
33
  LinkToFile:=False, _
34
34
 
@@ -212,7 +212,7 @@
212
212
 
213
213
  Worksheets(クリエイティブ).Shapes.AddPicture _
214
214
 
215
- , Filename:=myName, _
215
+ 　Filename:=myName, _
216
216
 
217
217
  LinkToFile:=False, _
218
218
 

3

現在発生しているエラー内容の更新

2021/09/16 06:44

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -18,13 +18,13 @@
18
18
 
19
19
  ```
20
20
 
21
- コンパイルエラー
22
-
23
21
  （最新の内容だと）
24
22
 
25
-
23
+ 実行時エラー'9'
26
-
24
+
25
+
26
+
27
- エラーに関しては以下の箇所が赤字で構文エラーになっています。
27
+ エラーに関しては以下の箇所が黄色マーカーで「インデックスが有効範囲にありません」と表示されています。
28
28
 
29
29
  Worksheets(クリエイティブ).Shapes.AddPicture _
30
30
 

2

③ご回答頂き修正したコード(その1）を追記

2021/09/16 06:21

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -20,7 +20,7 @@
20
20
 
21
21
  コンパイルエラー
22
22
 
23
- （最新の内容だと）構文エラー
23
+ （最新の内容だと）
24
24
 
25
25
 
26
26
 
@@ -28,15 +28,15 @@
28
28
 
29
29
  Worksheets(クリエイティブ).Shapes.AddPicture _
30
30
 
31
- Filename:=myName, _
31
+ , Filename:=myName, _
32
-
32
+
33
- LinkToFile:=False, _
33
+ LinkToFile:=False, _
34
-
34
+
35
- SaveWithDocument:=True, _
35
+ SaveWithDocument:=True, _
36
-
36
+
37
- LockAspectRatio:=mso True, _
37
+ LockAspectRatio:=msoTrue, _
38
-
38
+
39
- Height:=49.5
39
+ Height:=49.5
40
40
 
41
41
 
42
42
 
@@ -172,6 +172,76 @@
172
172
 
173
173
  ```
174
174
 
175
+ ③ご回答頂き修正したコード(その1）
176
+
177
+
178
+
179
+ ```
180
+
181
+ Sub 画像一括挿入()
182
+
183
+ Dim shpPic As Shape
184
+
185
+ Dim myNo As Long
186
+
187
+ Dim i As Long
188
+
189
+ Dim myRow As Long
190
+
191
+ Dim myName As String
192
+
193
+
194
+
195
+ myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
196
+
197
+ myNo = 1
198
+
199
+ myRow = 2
200
+
201
+
202
+
203
+ Worksheets("クリエイティブ").Select
204
+
205
+ Do Until myNo > myDataCnt
206
+
207
+ myName = Worksheets("CRデータ").Cells(myNo, 1).Value
208
+
209
+
210
+
211
+ 　　　　　　 Cells(myRow, 2).Select
212
+
213
+ Worksheets(クリエイティブ).Shapes.AddPicture _
214
+
215
+ , Filename:=myName, _
216
+
217
+ LinkToFile:=False, _
218
+
219
+ SaveWithDocument:=True, _
220
+
221
+ LockAspectRatio:=msoTrue, _
222
+
223
+ Height:=49.5
224
+
225
+ With shp
226
+
227
+ .Left = Range("D6").Left
228
+
229
+ .Top = Range("D6").Top
230
+
231
+ End With
232
+
233
+ Loop
234
+
235
+
236
+
237
+ End Sub
238
+
239
+
240
+
241
+ ```
242
+
243
+
244
+
175
245
  ※VBA/マクロに関しては素人なので色々コードが混在していると思います。。。
176
246
 
177
247
 

1

エラー箇所と表示内容について追記しました。

2021/09/16 06:18

投稿

rainbow0707
rainbow0707

スコア2

test CHANGED
File without changes
test CHANGED
@@ -22,6 +22,28 @@
22
22
 
23
23
  （最新の内容だと）構文エラー
24
24
 
25
+
26
+
27
+ エラーに関しては以下の箇所が赤字で構文エラーになっています。
28
+
29
+ Worksheets(クリエイティブ).Shapes.AddPicture _
30
+
31
+ Filename:=myName, _
32
+
33
+ LinkToFile:=False, _
34
+
35
+ SaveWithDocument:=True, _
36
+
37
+ LockAspectRatio:=mso True, _
38
+
39
+ Height:=49.5
40
+
41
+
42
+
43
+ 前部分の構文との組合せでそうなっているのかわかりません。
44
+
45
+ 一番最初の「Sub 画像一括挿入（）」の箇所は黄色マーカーが引かれていて左から➡も表示されています。
46
+
25
47
  ```
26
48
 
27
49