ここから本文です

JPGの貼り付けについて教えてください。

chi********さん

2018/7/1116:25:58

JPGの貼り付けについて教えてください。

JPGの縦横の比率は変わってしまいますが、
1枚目をC15~W42
2枚目をC56~W83
3枚目をC97~W124
の大きさにしたいので、WidthとHeightに数値を設定しましたが、
セル範囲にあいません。
セル範囲の大きさに合わせるにはどうしたらいいのでしょうか?

それと、JPGを張り付ける台帳が、
1シートに3枚のJPGを張り付けるようになっています。
シートは写真の枚数分用意されています。
JPGは1からの連番の名前がついています。
シートの1枚目には1~3のJPG
2枚目には4~6のJPG
といったように、シートの枚数分マクロを実行するだけで、
JPGを張り付ける方法があれば是非、教えてください。


どなたかわかる方、1つ目のセルに合わせる方法だけでも
いいので教えてください。よろしくお願いいたします。


Sub 写真張り付け()

Dim lngTop As Long
Dim objFile As Object
Dim objFldr As FileSystemObject
Dim StrPath As String

'エラーを無視する
On Error Resume Next


Set objFldr = CreateObject("Scripting.FileSystemObject")

With Application.FileDialog(msoFileDialogFolderPicker)
.Show

StrPath = .SelectedItems(1)

End With

Range("C15").Select

For Each objFile In objFldr.GetFolder(StrPath).Files
With ActiveSheet.Shapes.AddPicture( _
Filename:=objFile, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=Selection.Left, _
Top:=Selection.Top, _
Width:=1034.9291338583, _
Height:=384.6614173228)


End With


'次の図までの行数
ActiveCell.Offset(41, 0).Select

Next

End Sub

閲覧数:
58
回答数:
1
お礼:
50枚

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

kky********さん

2018/7/1210:53:14

写真を添付する大きいセル範囲は結合されているものとします。
シートはあらかじめ写真全部が入るように用意されている前提です。

Sub 写真張り付け()
Dim objFldr As Object
Dim objFile As Object
Dim StrPath As String
Dim i As Integer, j As Integer
Dim cnt As Integer
Dim rng As Range
Dim shp As Shape
Set objFldr = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = False Then Exit Sub
StrPath = .SelectedItems(1)
End With
Application.ScreenUpdating = False
'今までの画像を削除
For i = 1 To Worksheets.Count
For j = 15 To 97 Step 41
Worksheets(i).Activate
For Each objFile In ActiveSheet.Shapes
If objFile.Type = msoLinkedPicture Or objFile.Type = msoPicture Then
If Not Intersect(objFile.TopLeftCell, Range("C" & j)) Is Nothing Then
objFile.Delete
End If
End If
Next objFile
Next j
Next i
'画像添付
i = 0
For Each objFile In objFldr.GetFolder(StrPath).Files
cnt = cnt + 1
If cnt Mod 3 = 1 Then
i = i + 1
End If
With Worksheets(i)
.Activate
Select Case cnt Mod 3
Case 1
Set rng = .Range("C15")
Case 2
Set rng = .Range("C56")
Case 0
Set rng = .Range("C97")
End Select
End With
With rng
Set shp = ActiveSheet.Shapes.AddPicture(Filename:=StrPath & "\" & objFile.Name, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=.Left, Top:=.Top, Width:=.MergeArea.Width, Height:=.MergeArea.Height)
End With
Next objFile
Application.ScreenUpdating = True
End Sub

質問した人からのコメント

2018/7/12 14:39:21

ありがとうございます!
セル結合はしていなかったのですが、セル結合して実行すると
理想的な結果になりました。
ほんとスゴイです!ありがとうございました!!

あわせて知りたい

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる