[[20170219111828]]　『画像貼り付けについて』（emiko）　ページの最後に飛ぶ

『画像貼り付けについて』（emiko）

複数のフォルダがあり、フォルダ内に入っている写真をEXCELに貼り付けて
フォルダごとに保存していくマクロを実行したいと考えています。

フォルダに入っている名前がバラバラの写真jpg(最大６枚)を自動で貼り付ける
マクロを組んでいて、セル【J27】【K27】【L27】【J39】【K39】【L39】に
貼り付けて保存したいと考えています。
色々と調べたりして作成しているのですがうまくいきません。
ご教授宜しくお願いします。
下記がコードです。

 Dim fpath As String, fname As String, tname As String
 Dim x As Long, y As Long

 Application.ScreenUpdating = False
 fpath = "C:\"                         'CドライブのDフォルダ内
 tmpath = fpath & "d\" & (j.Cells(i, 1).Value) & "\"　’セル名前と一致しているファルダ
 fname = Dir(tmpath & "*.jpg", vbNormal)
 tname = tmpath & fname
 y = 10
 x = 10

 Do Until fname = ""

  If y < 13 Then

  s.Cells(27, y).Select
  With s.Pictures.Insert(tname)
 .Left = Selection.Left
 .Top = Selection.Top
 .Width = Selection.Width
 .Height = Selection.Height
  End With
  y = y + 1

 Else

  s.Cells(39, x).Select
  With s.Pictures.Insert(tname)
 .Left = Selection.Left
 .Top = Selection.Top
 .Width = Selection.Width
 .Height = Selection.Height
   End With
  x = x + 1
  End If

  fname = Dir()

 Loop

 'Next x
  Application.ScreenUpdating = True

  w.SaveAs (p & "\E\" & j.Cells(i, 1).Value & ".xlsx")　’Eフォルダに名前をつけてxlsxで保存
  w.Close
 Next i

宜しくお願いします。

＜使用 Excel：Excel2010、使用 OS：Windows10 ＞

 このコードは先頭から最後までのフルセットですか？

 > tmpath = fpath & "d\" & (j.Cells(i, 1).Value) & "\"　’セル名前と一致しているファルダ

 j.Cells とありますから j はシートオブジェクト？　でも、それを格納しているところがありません。
 i は　行番号変数でしょうけど、具体的にはどこで、何をセットしているのでしょうか？

 まぁ、それはそれとして。

 >うまくいきません。

 うまくいかない　とは、具体的には？

 ・どこかでエラーになる？
 ・画像が張りつかない？
 ・張り付くけど、思った場所に貼りつかない？

 等々、いろんな　『うまくいかない』状態がありますので。

 それを、回答側で、コードをよ～く読んだり、さらには実行してみて、どこがうまくいかないかを見つけなさい　というのは
 いささか・・・（コード自体が、中途半端で For/Netx の For が見えませんし）

（ β） 2017/02/19(日) 11:34

 状況を具体的に説明してもらい、コードも、ちゃんとフルセットアップしてもらえれば
 皆さんから回答がつくと思いますが、それとは別に。

 コードをデバッグするうえでも、きちんとインデントをつけましょう。
 アップされた部分だけでも以下のようになっていたら、ロジックが追いかけやすいでしょ？

 また、コードがフルセットではないので、もしかしたら見えていないところで規定されているのかもしれませんが
 変数はすべて定義しましょう。そのためにもモジュール先頭には必ず Option Explicit を記述しましょう。
 VBE画面のツール->オプション->編集タブ　で　変数の宣言を強制する(R) にチェックしておくと
 モジュールを挿入した時に自動的に記述されます。

 Option Explicit なしで、かつ未定義の変数を使ってコードを書くと、記述ミスによるトラブルが発生し
 しかも、その発見に時間がかかるという、無駄なことが発生しますので。

    Dim fpath As String, fname As String, tname As String
    Dim x As Long, y As Long
    Dim i As Long
    Dim j As Worksheet

    Application.ScreenUpdating = False
    fpath = "C:\"                         'CドライブのDフォルダ内
    tmpath = fpath & "d\" & (j.Cells(i, 1).Value) & "\"  'セル名前と一致しているファルダ
    fname = Dir(tmpath & "*.jpg", vbNormal)
    tname = tmpath & fname
    y = 10
    x = 10

    Do Until fname = ""

        If y < 13 Then

            s.Cells(27, y).Select
            With s.Pictures.Insert(tname)
                .Left = Selection.Left
                .Top = Selection.Top
                .Width = Selection.Width
                .Height = Selection.Height
            End With
            y = y + 1

        Else

            s.Cells(39, x).Select
            With s.Pictures.Insert(tname)
                .Left = Selection.Left
                .Top = Selection.Top
                .Width = Selection.Width
                .Height = Selection.Height
            End With
            x = x + 1
        End If

        fname = Dir()

    Loop

    'Next x
    Application.ScreenUpdating = True

    w.SaveAs (p & "\E\" & j.Cells(i, 1).Value & ".xlsx")  'Eフォルダに名前をつけてxlsxで保存
    w.Close
 Next i

（ β） 2017/02/19(日) 11:53

 私の知る限り、サロン、質問箱、mougでも同じ質問をしてるんですね。

 サロンはマルチ禁止なので、マナー違反です。

 他の掲示板も基本回答者は共通の人が多いので、βさんから回答もついてるので、
 他の掲示板はこちらで続ける旨を明記して解決済みにしてはどうでしょうか。

（sy） 2017/02/19(日) 12:08

過去ログにも似た案件がありますので、参照してみてください。
[[20170130105203]]
（???） 2017/02/19(日) 14:15

試験環境作るのが手間なので、セル番地はA1-C1とA2-C2で作ってます。
マクロが入ったシートに「フォルダ名」の入ったシートと「写真」を格納する空のシートを置いてあることを前提にしています。
こちらExcel2007しかないので、2010で動くかは未検証です。
Option Explicit
Sub test()

  Dim AdrStr As String, Adr As Variant
  Dim i As Long, j As Long, iMax As Long
  Dim wPath As String
  Dim wb As Workbook
  Dim ws As Worksheet, oWs As Worksheet
  Dim wx As Double, wy As Double
  Dim Pic As Variant, MyName As Variant, wName As String
  Dim flg As Boolean

  '写真貼付先セルの設定
  AdrStr = "A1,B1,C1,A2,B2,C2"
  Adr = Split(AdrStr, ",")

  Set ws = ThisWorkbook.Worksheets("フォルダ名")
  iMax = ws.Range("A" & Rows.Count).End(xlUp).Row
  For i = 2 To iMax 'フォルダ名の取得ループ
    wPath = ThisWorkbook.Path & "\D\" & ws.Range("A" & i)
    MyName = Dir(wPath & "\", vbNormal)
    j = 0: flg = False
    Do While MyName <> ""    ' ループを開始します。
      If MyName <> "." And MyName <> ".." And MyName Like "*.jpg" Then
        j = j + 1
        If j > 6 Then Exit Do '6枚を超える場合抜ける
        If j = 1 Then
          Set wb = Workbooks.Add
          ThisWorkbook.Worksheets("写真").Copy Before:=wb.Worksheets(1)
          Set oWs = wb.Worksheets("写真")
          flg = True
        End If
        wName = wPath & "\" & MyName
        '写真の縦横比により大きさを決定
        Set Pic = LoadPicture(wName)
        wx = ThisWorkbook.Worksheets("写真").Range(Adr(0)).Width
        wy = CLng(CDbl(Pic.Height) * 24 / 635) * wx / CLng(CDbl(Pic.Width) * 24 / 635)
        oWs.Shapes.AddPicture wName, True, True, oWs.Range(Adr(j - 1)).Left, oWs.Range(Adr(j - 1)).Top, wx, wy
        oWs.Range(Adr(j - 1)).Value = MyName
      End If
      MyName = Dir
    Loop
    If flg Then '写真ブックの保存
      wb.SaveAs ThisWorkbook.Path & "\E\" & ws.Range("A" & i) & ".xlsx"
      wb.Close
    End If
  Next i
End Sub

（ななし） 2017/02/20(月) 10:35

追記：
Excel 2010 で Pictures.Insert メソッドを使用して図をワークシートに挿入すると図がリンクオブジェクトとして挿入されるとのことなので、Shapes.AddPicture　で作成してあります。

https://support.microsoft.com/ja-jp/help/2396509
（ななし） 2017/02/20(月) 10:43

コメント返信：

[ 一覧(最新更新順) ]

[[20170219111828]] 『画像貼り付けについて』（emiko） ページの最後に飛ぶ

[[20170219111828]]　『画像貼り付けについて』（emiko）　ページの最後に飛ぶ