Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3626 / 76735

←次へ　｜　前へ→


	【78738】Re:ファルダ内の画像を任意のセルに貼り付ける方法

β - 17/1/11(水) 15:25 -


	引用なし

	パスワード

▼VBA勉強中さん：

セルの関係がちょっとわかりにくくなりました。

実際と異なれば、適宜、数字を調整してください。

Sub Test2()
　　Dim posRow As Long
　　Dim posCol As Long
　　Dim Pos As Range
　　Dim fPath As String
　　Dim fName As String
　　Dim Target As Range
　　Dim dic As Object
　　Dim cnt As Long
　　Dim sh1 As Worksheet
　　
　　Set sh1 = Sheets("Sheet1")　'★対象シート
　　sh1.Pictures.Delete
　　
　　posRow = 5　'5行目
　　posCol = 4　'D列
　　Set Pos = sh1.Cells(posRow, posCol).MergeArea '最初の参照セルはD5から始まる結合セル
　　
　　Set dic = CreateObject("Scripting.Dictionary")
　　fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\画像フォルダ\"　'★
　　
　　Do While Not IsEmpty(Pos)
　　　　fName = Right(Pos(1).Value, 3) & Pos.Offset(1).Value & ".jpg"
　　　　fName = Dir(fPath & fName)
　　　　If fName <> "" Then
　　　　　　If Not dic.exists(fName) Then
　　　　　　　　dic(fName) = True
　　　　　　　　Set Target = Pos.Offset(, 2).MergeArea
　　　　　　　　With ActiveSheet.Shapes.AddPicture(Filename:=fPath & fName, LinkToFile:=False, _
　　　　　　　　　　SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
　　　　　　　　　　Width:=-1, Height:=-1)　　　'-1 元の大きさで貼り付け
　　　　　　　　　　'===============タテヨコの縮尺を保持して拡大または縮小
　　　　　　　　　　.LockAspectRatio = True　　 '縦横比率の維持（念のため）
　　　　　　　　　　.Width = Target.Width * 0.9
　　　　　　　　　　If .Height > Target.Height * 0.9 Then .Height = Target.Height * 0.9
　　　　　　　　　　'===============中央へ調整
　　　　　　　　　　.Top = Target.Top + Target.Height / 2 - .Height / 2
　　　　　　　　　　.Left = Target.Left + Target.Width / 2 - .Width / 2
　　　　　　　　End With
　　　　　　End If
　　　　End If
　　　　
　　　　'次の参照セル
　　　　If Pos.Column = 4 Then　'D列
　　　　　　posCol = 15　'O列
　　　　　　cnt = cnt + 1
　　　　Else
　　　　　　If cnt Mod 2 = 0 Then
　　　　　　　　posRow = posRow + 22
　　　　　　Else
　　　　　　　　posRow = posRow + 17
　　　　　　End If
　　　　　　posCol = 4　 'D列
　　　　End If
　　　　
　　　　Set Pos = sh1.Cells(posRow, posCol).MergeArea
　　
　　Loop
　　
End Sub

1 hits

▼

【78726】ファルダ内の画像を任意のセルに貼り付ける方法 VBA勉強中 17/1/10(火) 17:11