エクセルマクロでサイズを指定して画像を一括貼り付けしたいです。
前任者が作成したマクロです。写真のサイズを指定したいのですができません。私はマクロ初心者の為このコードは難しくて理解できません。どうかよろしくお願い致します。
Sub 複数画像の挿入()
Dim c, sr, sc, s, rr, pkfile, ar, ac, rc, ccc, ca0
On Error GoTo err
Set a = Application.InputBox("画像挿入するセル選択" _
& Chr(13) & Chr(10) & "複数選択可" _
, "複数画像の一括挿入(セル選択)", Selection.Address, , , , , 8)
Application.ScreenUpdating = False
a.Select
sr = Selection.Row
sc = Selection.Column
rr = sr
pkfile = Application.GetOpenFilename _
("すべての図(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif), *.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.gif", 2, "挿入する図の選択(複数選択可)", , True)
If Not IsArray(pkfile) Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
For fi = 1 To UBound(pkfile)
If pkfile(fi) = False Then MsgBox "ファイルが指定されていません", , "複数画像の一括挿入": End
Next fi
n = ActiveSheet.Pictures.Count
Application.DisplayAlerts = False
ar = a.Address
ac = Range(ar).Count
fi = 1
If ac > 1 Then GoTo ech Else GoTo pc
ech:
ca0 = ""
For Each cc In ActiveSheet.Range(ar)
ca = Range(cc.Address).MergeArea.Address
rc = Range(ca).Rows.Count
ccc = Range(ca).Columns.Count
If rc > 1 Or cc > 1 Then
ca = Cells(Range(ca).Row + rc - 1, Range(ca).Column + ccc - 1).Address
End If
If ca0 = ca Then GoTo mne
ca0 = ca
ca = Range(cc.Address).MergeArea.Address
Range(ca).Select
g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
fl = pkfile(fi)
fi = fi + 1
If fi = UBound(pkfile) + 1 Then GoTo en
mne:
Next
Application.DisplayAlerts = True
a.Select
Exit Sub
pc:
For fi = 1 To UBound(pkfile)
ca = Cells(rr, sc).Address
Range(ca).Select
g = ActiveSheet.Pictures.Insert(pkfile(fi)).Name
fl = pkfile(fi)
rr = rr + 1
Next fi
Exit Sub
en:
Application.DisplayAlerts = True
Application.ScreenUpdating = False
a.Select
Exit Sub
err: MsgBox "選択が正しくありません"
End Sub
No.2ベストアンサー
- 回答日時:
ついでに。
Sub 複数画像の挿入() の動作にちょっと興味を惹かれましたので
習作してみました。
期待動作が違っていたら、こちらは捨て置いてください。
Sub try()
Dim a As Range
Dim cc As Range
Dim W As Single
Dim H As Single
Dim mx As Long
Dim fi As Long
Dim i As Long
Dim pkfile
On Error GoTo extLine
With Application
Set a = .InputBox("画像挿入するセル選択" & vbLf & _
"複数選択可", _
"複数画像の一括挿入(セル選択)", _
Selection.Address, _
Type:=8)
pkfile = .GetOpenFilename("すべての図" & _
"(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
"*.jpe;*.png;*.bmp;*.gif)," & _
"*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
"*.jpe;*.png;*.bmp;*.gif", 2, _
"挿入する図の選択(複数選択可)", , True)
If Not IsArray(pkfile) Then
MsgBox "ファイルが指定されていません", , _
"複数画像の一括挿入"
GoTo extLine
End If
W = .InputBox("ヨコ", Type:=1)
H = .InputBox("タテ", Type:=1)
.ScreenUpdating = False
End With
mx = UBound(pkfile)
fi = 1
For Each cc In a
If cc.Address = cc.MergeArea.Item(1).Address Then
Call picIns(cc, pkfile(fi), W, H)
fi = fi + 1
If fi > mx Then
Set cc = Nothing
Exit For
End If
End If
Next
For i = fi To mx
Set a = a(a.Rows.Count, 1).Offset(1)
Call picIns(a, pkfile(i), W, H)
Next
extLine:
Set a = Nothing
Application.ScreenUpdating = False
With err()
If .Number <> 0 Then MsgBox .Number & ":" & .Description
End With
End Sub
Sub picIns(ByVal r As Range, _
ByVal s As String, _
ByVal W As Single, _
ByVal H As Single)
With ActiveSheet.Pictures.Insert(s).ShapeRange
If (W > 0) And (H > 0) Then
.LockAspectRatio = msoFalse
.Width = W
.Height = H
ElseIf W > 0 Then
.Width = W
ElseIf H > 0 Then
.Height = H
End If
.Left = r.Left
.Top = r.Top
End With
End Sub
No.1
- 回答日時:
挿入する複数の画像全て同じサイズにしたい、という解釈で良いですか?
その前提で話をすすめます。
ご提示のマクロで望みの動作ができているなら、
サイズ指定マクロを作成して、その中で Sub 複数画像の挿入()を呼び出し、
最後にサイズ変更すれば良いです。
Sub macro()
Dim W As Single 'ヨコ
Dim H As Single 'タテ
Dim mn As Long '挿入前の枚数
Dim i As Long
W = Application.InputBox("写真サイズのヨコは?", Type:=1)
H = Application.InputBox("写真サイズのタテは?", Type:=1)
'挿入前の枚数を記憶しておいてSub 複数画像の挿入を呼び出す
mn = ActiveSheet.Pictures.Count
Call 複数画像の挿入
With ActiveSheet.Pictures
'挿入なしはExit Sub
If .Count = mn Then Exit Sub
For i = mn + 1 To .Count
.Item(i).Select False
Next
End With
'挿入写真のみ選択してサイズ変更
With Selection.ShapeRange
'W,Hとも指定した場合は縦横比変更して指定サイズに。
If (W > 0) And (H > 0) Then
.LockAspectRatio = msoFalse
.Width = W
.Height = H
'Wのみ指定は縦横比を保持してWのみ変更
ElseIf W > 0 Then
.Width = W
'Hのみ指定は縦横比を保持してHのみ変更
ElseIf H > 0 Then
.Height = H
'どちらも指定しなければサイズ変更しない。
Else
End If
End With
ActiveCell.Activate
End Sub
こんな感じです。
上記はApplication.InputBoxを使ってユーザーにサイズを入力してもらう例ですが、
固定値でも構わない場合は、InputBoxを使わず直接Width,Heightを指定してください。
If (W > 0) And (H > 0) Then...等の条件分岐も必要なくなります。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Visual Basic(VBA) 動きっぱなしです。止め方とプロシージャの間違いを教えて下さい! 5 2022/08/15 23:08
- Visual Basic(VBA) ファイル全てを .xlsm に変更したところ、プログラムが途中で落ちてしまっています 17 2022/12/07 12:03
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) VBAでoutlook365が起動しません。 4 2022/08/25 13:31
- Visual Basic(VBA) 【追加】ファイルを閉じてダイアログで保存した時だけ処理の実行をする 3 2022/03/23 15:43
- Visual Basic(VBA) 【Excel VBA】自動メール送信の機能追加 5 2022/09/29 12:53
- Visual Basic(VBA) excel2021で実行できないマクロ。どこを直したらいいのか 2 2022/03/28 03:40
- Visual Basic(VBA) 形式を選択して貼り付け 以下のコードで「元」シートと「先」シートのA列に同じ値があったら指定範囲をコ 5 2022/11/11 07:30
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルで枠飾り
-
大学のレポートを書くためにWor...
-
エクセルのフッター(右)に入...
-
Word・Excelからスキャナーで画...
-
Win11で使える写真整理ソフトを...
-
写真9枚をA4紙に配置したい。
-
ヘッダーとフッダーの縦書き方法
-
Accessで請求書に印鑑を...
-
エクセルで作成した文に柄・模...
-
エクセルのフッダーに四角で囲...
-
PowerDirector 11で空白時間の挿入
-
一太郎の図形の固定のしかたが...
-
VBAで特定のセルに画像があれば...
-
word A4サイズの文書に挿入する...
-
挿入した画像の中に文字を入れ...
-
エクセルにjpgデータ貼り付ける...
-
数式のΣ記号が入力できません
-
ワード2013で図形に画像を挿入...
-
Excelに複数の写真を挿入する場合…
-
前回のドラレコのSDカードにつ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルで枠飾り
-
大学のレポートを書くためにWor...
-
エクセルのフッダーに四角で囲...
-
エクセルのフッター(右)に入...
-
PowerDirector 11で空白時間の挿入
-
エクセルで写真の挿入 セルの中...
-
エクセルVBAで縦向きの画像の挿...
-
写真9枚をA4紙に配置したい。
-
ヘッダーとフッダーの縦書き方法
-
EXCELのフッターにオートシェイ...
-
フッターを「最前面」に
-
エクセルで作成した文に柄・模...
-
Win11で使える写真整理ソフトを...
-
EXCELにjpg画像を挿入...
-
OO.oのDrawで挿入絵の背景を透...
-
VBAで特定のセルに画像があれば...
-
Accessで請求書に印鑑を...
-
Wordに貼り付ける図の初期設定変更
-
保存や挿入などフォルダを開く...
-
GoodNotes5で、画像を複数選択...
おすすめ情報