質問: true end sub よろしくおねがいします。 ※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。
回答: >1エクセルシートのa2,b2,c2,d2,a4,b4,c4,d4 ...a24,b24,c24,d24セルに画像を挿入 >2マクロを開始するとフォルダを選ぶ画面が現れる >3フォルダを選択すると、1にフォルダ内の画像がすべて貼り付けられる >4画像は、セルの大きさに合わせて自動調整される 1は、a2で始まり、横に4進み、下に2進むという数列を設けています。 2は、ご存知のshell のbrowseforfolderを利用しましたが、他にもあるでしょう。 問題は3かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトしてください。また、doevents も入れておきました。 4は、何も手を付けていません。 コメント・アウトした部分で不要なら削除してください。 '// sub 図11r() 'no. 9024507 dim strfilter as string dim filenames() as variant dim fname as variant, ext as string dim pic as picture dim k as long, m as long dim i as long, j as long dim cnt as long dim firstrng as range dim r as range dim sel_folder as object, sel_path as string cnt = 0 'カウントの初期値 '貼り付け最初のセル set firstrng = range("a2") set sel_folder = createobject("shell.application"). _ browseforfolder(0, "フォルダを選択してください", 5) if not sel_folder is nothing then sel_path = sel_folder.self.path else exit sub end if ' 「ファイルを開く」ダイアログでファイル名を取得 chdir sel_path ' strfilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png" ' filenames = application.getopenfilename( _ ' filefilter:=strfilter, _ ' title:="図の挿入(複数選択可)", _ ' multiselect:=true) fname = dir("*.*", vbnormal) do while fname <> "" if fname <> "." and fname <> ".." then ext = mid(fname, instrrev(fname, ".") + 1) if instr(1, "jpg,jpeg,gif,bmp,png", ext, 1) > 0 and not fname like "#*" then cnt = cnt + 1 doevents redim preserve filenames(1 to cnt) filenames(cnt) = fname ''安全のため(上限を設定) if cnt > 100 then exit do end if end if fname = dir() loop if cnt = 0 then exit sub ' ファイル名をソート call bubblesort_str(filenames, true, vbtextcompare) '' 貼り付け開始セルを選択 'range("b6").select ' マクロ実行中の画面描写を停止 application.screenupdating = false ' 順番に画像を挿入 k = lbound(filenames) m = ubound(filenames) for j = 1 to int(m / 4) + abs(m mod 4 > 0) for i = 1 to 4 set pic = activesheet.pictures.insert(filenames(k)) set r = firstrng.cells(1 + (j - 1) * 2, i) '------------------------------------------------------------- ' 画像の各種プロパティ変更 '------------------------------------------------------------- with pic .top = r.top ' 位置:アクティブセルの上側に重ねる .left = r.left ' 位置:アクティブセルの左側に重ねる .placement = xlmove ' 移動するがサイズ変更しない .printobject = true ' 印刷する end with with pic.shaperange .lockaspectratio = msotrue ' 縦横比維持 ' 画像の高さをアクティブセルにあわせる ' 結合セルの場合でも対応 .height = r.mergearea.height end with ' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル] ' activecell.offset(5).select set pic = nothing k = k + 1 if k >= m then exit for next i next j application.screenupdating = true chdir thisworkbook.path end sub