Excel VBA質問箱 IV

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

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


4 / 12928 ツリー ←次へ | 前へ→

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

【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 お礼[未読]

【78733】Re:ファルダ内の画像を任意のセルに貼り...
発言  VBA勉強中  - 17/1/11(水) 12:02 -

引用なし
パスワード
   ▼β さん:
追記です。
Set Pos = Pos.Offset(, 11)
の部分をselect case 構文を用いようと思います。
列がFの場合、右に11進める
列がQで17行下が空だった場合、左に11、下に17進める
列がQで17行下が空ではない場合(画像を入れるセル以外にはすべて文字が入力されています)、左に11、下に22進める

としてみようかと思います。

Select Case True
      Case Pos = Sheets("sheet1").Range("F")
        Set Pos = Pos.Offset(, 11)
      Case Pos = Sheets("sheet1").Range("Q") & Pos.Offset(, 17) = ""
        Set Pos = Pos.Offset(-11, 17)
      Case Pos = Sheets("sheet1").Range("Q") & Pos.Offset(, 17) = "" = False
        Set Pos = Pos.Offset(-11, 22)
    End Select

このような風になりました。お時間あれば添削いただけると幸いです。

【78735】Re:ファルダ内の画像を任意のセルに貼り...
発言  β  - 17/1/11(水) 13:48 -

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

当初の説明と参照セル、貼付けセルが異なるようですね。
(私の勘違いかもしれませんが)

重複画像の扱いが、いまいちわからないのですが、以下で試してみてください。

Sub Test()
  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 x As Long
  
  With Sheets("Sheet1")  '★対象シート
    .Pictures.Delete
    Set Pos = Sheets("Sheet1").Range("E5")
  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
    
    If Pos.Column = 5 Then 'E列
      Set Pos = Pos.EntireRow.Range("P1")
      cnt = cnt + 1
    Else
      If cnt Mod 2 = 0 Then
        x = 22
      Else
        x = 17
      End If
      Set Pos = Pos.EntireRow.Range("E1").Offset(x)
    End If
    
  Loop
  
End Sub

【78737】Re:ファルダ内の画像を任意のセルに貼り...
発言  VBA勉強中  - 17/1/11(水) 14:34 -

引用なし
パスワード
   ▼β さん:
組みなおししていただき、ありがとうございます!
相変わらず説明不足が目立ち申し訳ありません
>▼VBA勉強中 さん:
>
>当初の説明と参照セル、貼付けセルが異なるようですね。
>(私の勘違いかもしれませんが)
>
>重複画像の扱いが、いまいちわからないのですが、以下で試してみてください。
>

こちらですが改めて説明させていただきます
参照セル:D5,D7(D5,D7ともに2列2行が結合している状態です)
貼り付けセル:F5(こちらは7列12行が結合しています)
重複画像についてはうまく説明できなくなってしまいました…
001-1~999-9まででn-nが2回以上使われないようにしたいものです。

testの実行をしてみましたがエラーはなにもなく、ひな形の写真が削除されるのみに留まりました。
また、
>当初の説明と参照セル、貼付けセルが異なるようですね。
これについてですが、私の間違いで貼り付けセルをposで扱っていました。
適当なミスをしてしまってすみません、最初の説明で合っています。

【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

【78739】Re:ファルダ内の画像を任意のセルに貼り...
発言  VBA勉強中  - 17/1/11(水) 15:58 -

引用なし
パスワード
   ▼β さん:
ありがとうございます!
読みやすい上にコメントがついているので理解しやすいです
実行してみましたがやはり画像が消えるのみで挿入はされませんでした。

>    fName = Right(Pos(1).Value, 3) & Pos.Offset(1).Value & ".jpg"
pos(1)ですが(1)とはなにを意味するのでしょうか、宣言した変数の最初の1個だから(1)…ということですか?
また、確かにデスクトップ上に"画像フォルダ"を作りそこに画像が入っているのですが挿入されない状態です。一応画像フォルダのプロパティを見てみたら、
C:\Users\*****\Desktop となっていました。tが小文字なのが原因なのかなと思いつつ修正してみましたが変化はありませんでした。

私の言葉足らずのために迷惑をかけてしまって本当にすみません…

【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

【78741】Re:ファルダ内の画像を任意のセルに貼り...
発言  β  - 17/1/11(水) 17:32 -

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

ごめんなさい。

画像ファイル名は 2つの値を - 連結させるんでしたね。
いつの間にか、そこを忘れていました。

fName = Right(Pos(1).Value, 3) & Pos.Offset(1).Value & ".jpg"

これを

fName = Right(Pos(1).Value, 3) & "-" & Pos.Offset(1).Value & ".jpg"

に変更してください。

【78742】Re:ファルダ内の画像を任意のセルに貼り...
お礼  VBA勉強中  - 17/1/12(木) 10:00 -

引用なし
パスワード
   ▼β さん:
無事、当初予定していた意図で動きました!
ありがとうございました!

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