Excel VBA質問箱 IV

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

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


230 / 73341 ←次へ | 前へ→

【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

58 hits

【78726】ファルダ内の画像を任意のセルに貼り付ける方法 VBA勉強中 17/1/10(火) 17:11 質問[未読]
【78727】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/10(火) 19:30 発言[未読]
【78730】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/10(火) 20:07 発言[未読]
【78731】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/10(火) 20:33 発言[未読]
【78732】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/11(水) 10:58 発言[未読]
【78734】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/11(水) 12:47 発言[未読]
【78736】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/11(水) 13:54 お礼[未読]
【78733】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/11(水) 12:02 発言[未読]
【78735】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/11(水) 13:48 発言[未読]
【78737】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/11(水) 14:34 発言[未読]
【78738】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/11(水) 15:25 発言[未読]
【78739】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/11(水) 15:58 発言[未読]
【78741】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/11(水) 17:32 発言[未読]
【78742】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/12(木) 10:00 お礼[未読]
【78740】Re:ファルダ内の画像を任意のセルに貼り付... VBA勉強中 17/1/11(水) 17:23 お礼[未読]
【78728】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/10(火) 19:36 発言[未読]
【78729】Re:ファルダ内の画像を任意のセルに貼り付... β 17/1/10(火) 19:45 発言[未読]

230 / 73341 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free