Excel VBA質問箱 IV

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

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


422 / 73531 ←次へ | 前へ→

【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

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

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