Excel VBA質問箱 IV

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

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


90 / 13014 ツリー ←次へ | 前へ→

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

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

【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

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

引用なし
パスワード
   ▼β さん:
すごすぎます、短時間、あの説明でここまで作っていただけるとは…ありがとうございます!
一通りわからないものについては調べて参りました。
Scripting.Dictionary、WScript.Shell につきましてわからずでして
前者が重複を防いでほしいとこの画像をオブジェクトに指定している
後者はとても多くのメソッドとプロパティを内包しているんですね…
2つとも CreateObjectを使われていることから画像とファイルを操作できるように指定してしているのかな?といった認識です。合っていますか?
といっても CreateObjectも先ほど調べて把握したばかりで恥ずかしい話ですが…すごく便利なものですね

また、Set Pos = Pos.Offset(, 11)
ここです、これも説明不足で申し訳ないのですが
画像の貼り付け場所なのですが1ページに4枚貼ります、位置は左上、右上、左下、右下、の順になります。
これが20ページ以上ほどありまして自動化できないだろうかと考えている状態です
1ページ目の上下間と、1ページ目の下側と2ページ目の上側間が違うため(左側の列は常にF、右側はQです)
画像位置の順は、F5,Q5,F22,Q22,F44,Q44,F61,Q61,F83,Q83....
画像名を参照するセルは、常に画像位置のセルから左に1進んだもの右3文字と、左に1、下に2つ進んだものの数値になります。
(F5の場合、D5の右3文字,D7の数値)

組んでいただいたものは非常に見やすく、勉強になりました。
今から自分でもこれをもとに作ってみます
ありがとうございます。
とは言いましてもおそらく詰まってしまうのでまたお時間あればご連絡いただけると幸いです。

【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

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

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

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

まず、質問されている部分。

>2つとも CreateObjectを使われていることから画像とファイルを操作できるように
>指定してしているのかな?といった認識です。合っていますか?

そうではありません。
VBAコードを書く際に、エクセルオリジナル機能だけで処理できればいいのですが
エクセルとは別のプログラム(外部プログラム)の機能を使いたいという場合があります。

そういった場合、その外部プログラムを読みこんで、VBAから利用できるように
しなければいけません。 
それが CreateObject("定められたプログラム呼び出し文字列") です。

"WScript.Shell" は、調べられた通り、実に様々な機能を提供してくれます。
今回使ったのは、その中の SpecialFolders("特殊フォルダ指定文字列") です。

たとえば デスクトップ のパス、vista以降は c:\Users\xxxxx\DeskTop ですね。
この xxxxx は PCのWindowsログインID ですから、実行するPC毎に異なります。
また、Users というフォルダ以降、DeskTop に至るまでのパス経路も、Vista以降、
『たまたま』そういった経路になっているだけで、XP時代は、全く別物でした。
ということは、今後のWindowsバージョンアップに伴って、このパス経路そのものも
変わる可能性があります。

なので、コード内で固定せず、WScript.Shellプログラムに対して、現在のバージョンの
実行PCの環境にふさわしいパス文字列をくださいね と依頼して、その文字列を
取得しています。

"Scripting.Dictinary" は、一般に ディクショナリーといわれる機能で
文字通り 『辞書』。辞書には『見出し語』と『内容』が登録されていますね。
今回は、辞書に 抽出済み画像ファイル名を見出し語として登録しておき、
それが、すでに使われたかどうか(Existsメソッド)チェックしています。
(『内容』は、今回不要なので、いずれも True をセットしています)

追加で説明のあった件も含めて、処理コードについては、今から説明を読んでみて
取り掛かります。

【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

【78736】Re:ファルダ内の画像を任意のセルに貼り...
お礼  VBA勉強中  - 17/1/11(水) 13:54 -

引用なし
パスワード
   ▼β さん:

とても詳しくわかりやすい説明ありがとうございます
理解が少しだけ深まってきました
教えていただいたものはどれも非常に汎用性があり、今後もよく使っていく気がします。

【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 -

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

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