Excel VBA質問箱 IV

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

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


44 / 73146 ←次へ | 前へ→

【78731】Re:ファルダ内の画像を任意のセルに貼り付ける方法
発言  β  - 17/1/10(火) 20:33 -

引用なし
パスワード
   ▼VBA勉強中 さん:

まだ、ちょっとわかりにくいところもありますがたたき台。
★のところ、シート名とフォルダは実際のものにしてください。

Sub Test()
  Dim Pos As Range
  Dim fPath As String
  Dim fName As String
  Dim Target As Range
  Dim dic As Object
  
  With Sheets("Sheet1")  '★対象シート
    .Pictures.Delete
    Set Pos = Sheets("Sheet1").Range("D5")
  End With
  
  Set dic = CreateObject("Scripting.Dictionary")
  fPath = CreateObject("WScript.Shell").SpecialFolders("DeskTop") & "\画像フォルダ\" '★
  
  Do While Not IsEmpty(Pos)
    fName = Right(Pos.Value, 3) & Pos.Offset(2).Value & ".jpg"
    fName = Dir(fPath & fName)
    If fName <> "" Then
      If Not dic.exists(fName) Then
        dic(fName) = True
        Set Target = Pos.Offset(, 1)
        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
    Set Pos = Pos.Offset(, 11)
  Loop
  
End Sub

69 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 発言[未読]

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