| |
▼β さん：
追記です
> 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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 17/1/10(火) 20:07 -
