Excel VBA質問箱 IV

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

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


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

3624 / 76735

←次へ　｜　前へ→


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

VBA勉強中 - 17/1/11(水) 17:23 -


	引用なし

	パスワード

▼β さん：
追記です
>　　　　fName = Right(Pos(1).Value, 3) & Pos.Offset(1).Value & ".jpg"
ここを、
fName = Right(Pos(1).Value, 3) &　"-" & Pos.Offset(1).Value & ".jpg"
に変更したところ挿入されました。
ありがとうございます！
試しに写真10枚でやってみたところ問題なく作用したようです！
本当に今日はありがとうございました！

>▼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

0 hits

▼

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