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

編集履歴

質問編集履歴

11

初心者マークつけた

2021/09/16 14:23

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -5,7 +5,7 @@
5
5
  サイズ自動調整の一括画像貼り付けのVBA・マクロが組めたらいいのですが、その辺は知識が足りず、サンプルコードからの修正・応用も上手くいかなかったので、何かいい方法があればお聞きしたいです。
6
6
 
7
7
  ### 事前設定・前提条件
8
- ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。
8
+ ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。　
9
9
  ・同じくCドライブ内に今回対象のExcelファイルも格納済。
10
10
  ・シート名「CRデータ」に画像ファイルのパスコピーを入力済（A1は「画像パス」の文言、A2から実際の画像パス）
11
11
  ・シート名「クリエイティブ」が実際に画像を貼り付けるシートであり、D6から画像を貼付ける箇所として設定しています。

10

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

2021/09/16 14:22

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -15,51 +15,46 @@
15
15
 
16
16
  ```
17
17
  （最新の内容だと）
18
- 実行時エラー'9'
19
-
20
- エラーに関しては以下の箇所が黄色マーカーで「インデックスが有効範囲にありません」と表示されています。
21
- Worksheets(クリエイティブ).Shapes.AddPicture _
22
- 　Filename:=myName, _
23
- LinkToFile:=False, _
24
- SaveWithDocument:=True, _
25
- LockAspectRatio:=msoTrue, _
26
- Height:=49.5
27
-
28
- 前部分の構文との組合せでそうなっているのかわかりません。
18
+ 画像パスの1枚目の画像が指定のシート＆開始セルに貼り付けられたが、
29
- 一番最初の「Sub 画像一括挿入（）」の箇所は黄色マーカーが引かれていて左から➡も表示されています。
19
+ 10枚以上同じ画像が同じセルに元のサイズで貼り付けられた状態
30
20
  ```
31
21
 
32
22
  ### 該当のソースコード
33
23
 
34
- ①最初に試したコード
24
+ ④修正して現在のコード
35
25
  ```
36
26
  Sub 画像一括挿入()
27
+ Dim shpPic As Shape
28
+ Dim myNo As Long
29
+ Dim i As Long
30
+ Dim myRow As Long
31
+ Dim myName As String
37
- 　　　Dim myDataCnt As Long
32
+ Dim myDataCnt As Long
38
- 　　　Dim myNo As Long
33
+
39
- 　　　Dim i As Long
40
- 　　　Dim myRow As Long
41
- 　　　Dim myName As String
42
- 　　　
43
- 　　　myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
34
+ myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
44
- 　　　myNo = 1
35
+ myNo = 1
45
- 　　　myRow = 2
36
+ myRow = 2
46
- 　　　
37
+
47
- 　　　Worksheets("クリエイティブ").Select
38
+ Worksheets("クリエイティブ").Select
39
+ Dim shp As Object
48
- 　　　Do Until myNo > myDataCnt
40
+ For myNo = 1 To myDataCnt
49
- 　　　　　　myName = Worksheets("CRデータ").Cells(myNo, 1).Value
41
+ myName = Worksheets("CRデータ").Cells(2, 1).Value
50
- 　　　　　　
51
- 　　　　　　Cells(myRow, 2).Select
52
- 　　　　　　ActiveSheet.クリエイティブ.Insert(画像パス).Select
42
+ With Worksheets("クリエイティブ").Shapes.AddPicture _
43
+ (Filename:=myName, _
44
+ LinkToFile:=False, _
45
+ SaveWithDocument:=True, _
46
+ Left:=Range("D6").Left, _
47
+ Top:=Range("D6").Top, _
48
+ Height:=-1, _
49
+ Width:=-1)
53
- 　　　　　　Selection.ShapeRange.LockAspectRatio = msoTrue
50
+ LockAspectRatio = msoTrue
54
- 　　　　　　Selection.ShapeRange.Height = 49.5
55
- 　　　　　　myRow = myRow + 1
51
+ myRow = myRow + 1
56
- 　　　　　　myNo = myNo + 1
52
+ End With
57
- 　　　Loop
53
+ Next
58
- 　　　
59
- End Sub　
54
+ End Sub
60
55
  ```
61
56
 
62
- ②書き換えを試みたコード
57
+ ~~③ご回答頂き修正したコード(その1）~~
63
58
  ```
64
59
  Sub 画像一括挿入()
65
60
  Dim shpPic As Shape
@@ -76,23 +71,22 @@
76
71
  Do Until myNo > myDataCnt
77
72
  myName = Worksheets("CRデータ").Cells(myNo, 1).Value
78
73
 
79
- Cells(myRow, 2).Select
74
+ 　　　　　　 Cells(myRow, 2).Select
80
75
  Worksheets(クリエイティブ).Shapes.AddPicture _
81
- Filename:=myName, _
76
+ 　Filename:=myName, _
82
- LinkToFile:=False, _
77
+ LinkToFile:=False, _
83
- SaveWithDocument:=True, _
78
+ SaveWithDocument:=True, _
84
- LockAspectRatio:=mso True, _
79
+ LockAspectRatio:=msoTrue, _
85
- Height:=49.5
80
+ Height:=49.5
86
- With shp
81
+ With shp
87
- .Left = Range("D6").Left
82
+ .Left = Range("D6").Left
88
- .Top = Range("D6").Top
83
+ .Top = Range("D6").Top
89
- End With
84
+ End With
85
+ Loop
90
86
 
91
87
  End Sub
92
-
93
88
  ```
94
- ③ご回答頂き修正したコード(その1）
89
+ ~~②書き換えを試みたコード~~
95
-
96
90
  ```
97
91
  Sub 画像一括挿入()
98
92
  Dim shpPic As Shape
@@ -109,25 +103,48 @@
109
103
  Do Until myNo > myDataCnt
110
104
  myName = Worksheets("CRデータ").Cells(myNo, 1).Value
111
105
 
112
- 　　　　　　 Cells(myRow, 2).Select
106
+ Cells(myRow, 2).Select
113
107
  Worksheets(クリエイティブ).Shapes.AddPicture _
114
- 　Filename:=myName, _
108
+ Filename:=myName, _
115
- LinkToFile:=False, _
109
+ LinkToFile:=False, _
116
- SaveWithDocument:=True, _
110
+ SaveWithDocument:=True, _
117
- LockAspectRatio:=msoTrue, _
111
+ LockAspectRatio:=mso True, _
118
- Height:=49.5
112
+ Height:=49.5
119
- With shp
113
+ With shp
120
- .Left = Range("D6").Left
114
+ .Left = Range("D6").Left
121
- .Top = Range("D6").Top
115
+ .Top = Range("D6").Top
122
- End With
116
+ End With
123
- Loop
124
117
 
125
118
  End Sub
126
-
127
119
  ```
120
+ ~~①最初に試したコード~~
121
+ ```
122
+ Sub 画像一括挿入()
123
+ 　　　Dim myDataCnt As Long
124
+ 　　　Dim myNo As Long
125
+ 　　　Dim i As Long
126
+ 　　　Dim myRow As Long
127
+ 　　　Dim myName As String
128
+ 　　　
129
+ 　　　myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
130
+ 　　　myNo = 1
131
+ 　　　myRow = 2
132
+ 　　　
133
+ 　　　Worksheets("クリエイティブ").Select
134
+ 　　　Do Until myNo > myDataCnt
135
+ 　　　　　　myName = Worksheets("CRデータ").Cells(myNo, 1).Value
136
+ 　　　　　　
137
+ 　　　　　　Cells(myRow, 2).Select
138
+ 　　　　　　ActiveSheet.クリエイティブ.Insert(画像パス).Select
139
+ 　　　　　　Selection.ShapeRange.LockAspectRatio = msoTrue
140
+ 　　　　　　Selection.ShapeRange.Height = 49.5
141
+ 　　　　　　myRow = myRow + 1
142
+ 　　　　　　myNo = myNo + 1
143
+ 　　　Loop
144
+ 　　　
145
+ End Sub
146
+ ```
128
147
 
129
- ※VBA/マクロに関しては素人なので色々コードが混在していると思います。。。
130
-
131
148
  ###ここに言語名を入力
132
149
  ```
133
150
  ①VBE　（で違うことに気付いて②に書き換えのつもり）
@@ -146,6 +163,7 @@
146
163
  下記のコード引用して実行してみたが、リンク貼り付けになるためAddPictureに書き換えようと試みる
147
164
  https://xtech.nikkei.com/it/pc/article/NPC/20071101/286186/
148
165
  →コンパイルエラー続出（構文エラー等）
166
+ →いくつかの修正を経て④のコードが現在の状態
149
167
  ```
150
168
 
151
169
  ### 補足情報（FW/ツールのバージョンなど）

9

実現したいことの追記

2021/09/16 12:52

投稿

rainbow0707
rainbow0707

スコア2

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

8

補足情報の追記

2021/09/16 12:40

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -149,4 +149,5 @@
149
149
 
150
150
  ### 補足情報（FW/ツールのバージョンなど）
151
151
 
152
- ここにより詳細な情報を記載してください。
152
+ マクロ・VBAはこれまで触ったことがありません。全くの素人です。
153
+ 業務上、効率化するために今回検索して似た記述をベースにして作成してみましたが、全然わからないままエラーで苦戦している状態です。。。

7

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

2021/09/16 09:43

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -3,11 +3,12 @@
3
3
 
4
4
  サイズ自動調整の一括画像貼り付けのVBA・マクロが組めたらいいのですが、その辺は知識が足りず、サンプルコードからの修正・応用も上手くいかなかったので、何かいい方法があればお聞きしたいです。
5
5
 
6
- ### 事前設定
6
+ ### 事前設定・前提条件
7
7
  ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。
8
8
  ・同じくCドライブ内に今回対象のExcelファイルも格納済。
9
9
  ・シート名「CRデータ」に画像ファイルのパスコピーを入力済（A1は「画像パス」の文言、A2から実際の画像パス）
10
10
  ・シート名「クリエイティブ」が実際に画像を貼り付けるシートであり、D6から画像を貼付ける箇所として設定しています。
11
+ ・画像サイズは複数パターンあるため、（300x300や320x100等）Excelの行の高さを49.5(66ピクセル)、幅は21.88(180ピクセル）で設定しておりますが、縦横比維持したまま貼付けしたいので、一旦高さだけ合っていれば幅は問わず、あとは各セルの中に収まればいいと考えています。
11
12
 
12
13
  ### 発生している問題・エラーメッセージ
13
14
 

6

事前設定内容を修正

2021/09/16 07:20

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -5,8 +5,9 @@
5
5
 
6
6
  ### 事前設定
7
7
  ・今回貼付したい画像ファイルを格納したフォルダをCドライブ内に用意。
8
+ ・同じくCドライブ内に今回対象のExcelファイルも格納済。
8
- ・画像ファイルのパスコピーを貼付したいシートとは別のシート（今回はシート名「CRデータ」）に入力済。（A1は「画像パス」の文言、A2から実際の画像パス）
9
+ ・シート名「CRデータ」に画像ファイルのパスコピーを入力済（A1は「画像パス」の文言、A2から実際の画像パス）
9
- ・実際に貼付けるシート（シート名「クリエイティブ」）のD6から画像を貼付ける箇所としています。
10
+ ・シート名「クリエイティブ」が実際に画像を貼り付けるシートであり、D6から画像を貼付ける箇所として設定しています。
10
11
 
11
12
  ### 発生している問題・エラーメッセージ
12
13
 

5

事前設定内容を追記

2021/09/16 07:12

投稿

rainbow0707
rainbow0707

スコア2

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

4

コード修正

2021/09/16 07:09

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -13,7 +13,7 @@
13
13
 
14
14
  エラーに関しては以下の箇所が黄色マーカーで「インデックスが有効範囲にありません」と表示されています。
15
15
  Worksheets(クリエイティブ).Shapes.AddPicture _
16
- , Filename:=myName, _
16
+ 　Filename:=myName, _
17
17
  LinkToFile:=False, _
18
18
  SaveWithDocument:=True, _
19
19
  LockAspectRatio:=msoTrue, _
@@ -105,7 +105,7 @@
105
105
 
106
106
  　　　　　　 Cells(myRow, 2).Select
107
107
  Worksheets(クリエイティブ).Shapes.AddPicture _
108
- , Filename:=myName, _
108
+ 　Filename:=myName, _
109
109
  LinkToFile:=False, _
110
110
  SaveWithDocument:=True, _
111
111
  LockAspectRatio:=msoTrue, _

3

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

2021/09/16 06:44

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -8,10 +8,10 @@
8
8
  ### 発生している問題・エラーメッセージ
9
9
 
10
10
  ```
11
- コンパイルエラー
12
11
  （最新の内容だと）
12
+ 実行時エラー'9'
13
13
 
14
- エラーに関しては以下の箇所が赤字で構文エラーになっています。
14
+ エラーに関しては以下の箇所が黄色マーカーで「インデックスが有効範囲にありません」と表示されています。
15
15
  Worksheets(クリエイティブ).Shapes.AddPicture _
16
16
  , Filename:=myName, _
17
17
  LinkToFile:=False, _

2

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

2021/09/16 06:21

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -9,15 +9,15 @@
9
9
 
10
10
  ```
11
11
  コンパイルエラー
12
- （最新の内容だと）構文エラー
12
+ （最新の内容だと）
13
13
 
14
14
  エラーに関しては以下の箇所が赤字で構文エラーになっています。
15
15
  Worksheets(クリエイティブ).Shapes.AddPicture _
16
- Filename:=myName, _
16
+ , Filename:=myName, _
17
- LinkToFile:=False, _
17
+ LinkToFile:=False, _
18
- SaveWithDocument:=True, _
18
+ SaveWithDocument:=True, _
19
- LockAspectRatio:=mso True, _
19
+ LockAspectRatio:=msoTrue, _
20
- Height:=49.5
20
+ Height:=49.5
21
21
 
22
22
  前部分の構文との組合せでそうなっているのかわかりません。
23
23
  一番最初の「Sub 画像一括挿入（）」の箇所は黄色マーカーが引かれていて左から➡も表示されています。
@@ -85,6 +85,41 @@
85
85
  End Sub
86
86
 
87
87
  ```
88
+ ③ご回答頂き修正したコード(その1）
89
+
90
+ ```
91
+ Sub 画像一括挿入()
92
+ Dim shpPic As Shape
93
+ Dim myNo As Long
94
+ Dim i As Long
95
+ Dim myRow As Long
96
+ Dim myName As String
97
+
98
+ myDataCnt = Worksheets("CRデータ").Range("A2").End(xlDown).Row
99
+ myNo = 1
100
+ myRow = 2
101
+
102
+ Worksheets("クリエイティブ").Select
103
+ Do Until myNo > myDataCnt
104
+ myName = Worksheets("CRデータ").Cells(myNo, 1).Value
105
+
106
+ 　　　　　　 Cells(myRow, 2).Select
107
+ Worksheets(クリエイティブ).Shapes.AddPicture _
108
+ , Filename:=myName, _
109
+ LinkToFile:=False, _
110
+ SaveWithDocument:=True, _
111
+ LockAspectRatio:=msoTrue, _
112
+ Height:=49.5
113
+ With shp
114
+ .Left = Range("D6").Left
115
+ .Top = Range("D6").Top
116
+ End With
117
+ Loop
118
+
119
+ End Sub
120
+
121
+ ```
122
+
88
123
  ※VBA/マクロに関しては素人なので色々コードが混在していると思います。。。
89
124
 
90
125
  ###ここに言語名を入力

1

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

2021/09/16 06:18

投稿

rainbow0707
rainbow0707

スコア2

title CHANGED
File without changes
body CHANGED
@@ -10,6 +10,17 @@
10
10
  ```
11
11
  コンパイルエラー
12
12
  （最新の内容だと）構文エラー
13
+
14
+ エラーに関しては以下の箇所が赤字で構文エラーになっています。
15
+ Worksheets(クリエイティブ).Shapes.AddPicture _
16
+ Filename:=myName, _
17
+ LinkToFile:=False, _
18
+ SaveWithDocument:=True, _
19
+ LockAspectRatio:=mso True, _
20
+ Height:=49.5
21
+
22
+ 前部分の構文との組合せでそうなっているのかわかりません。
23
+ 一番最初の「Sub 画像一括挿入（）」の箇所は黄色マーカーが引かれていて左から➡も表示されています。
13
24
  ```
14
25
 
15
26
  ### 該当のソースコード