ネットでいろいろ検索し、試してみましたが自分の思うような仕上がりにならず困っています。
実施したい内容としては、マクロで
①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
②マクロを開始するとフォルダを選ぶ画面が現れる
③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
④画像は、セルの大きさに合わせて自動調整される
というものです。
1枚ずつを選んでセルに自動調整で貼り付けるということは真似事でできましたが、希望の内容をできるようにしようとすると、かなり難易度が高くお手上げ状態です。
このプログラムをどのように改修すれば可能になるかお教えください。
Sub 図11()
Dim strFilter As String
Dim Filenames As Variant
Dim PIC As Picture
' 「ファイルを開く」ダイアログでファイル名を取得
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可)", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub
' ファイル名をソート
Call BubbleSort_Str(Filenames, True, vbTextCompare)
' 貼り付け開始セルを選択
Range("B6").Select
' マクロ実行中の画面描写を停止
Application.ScreenUpdating = False
' 順番に画像を挿入
For i = LBound(Filenames) To UBound(Filenames)
Set PIC = ActiveSheet.Pictures.Insert(Filenames(i))
'-------------------------------------------------------------
' 画像の各種プロパティ変更
'-------------------------------------------------------------
With PIC
.Top = ActiveCell.Top ' 位置:アクティブセルの上側に重ねる
.Left = ActiveCell.Left ' 位置:アクティブセルの左側に重ねる
.Placement = xlMove ' 移動するがサイズ変更しない
.PrintObject = True ' 印刷する
End With
With PIC.ShapeRange
.LockAspectRatio = msoTrue ' 縦横比維持
' 画像の高さをアクティブセルにあわせる
' 結合セルの場合でも対応
.Height = ActiveCell.MergeArea.Height
End With
' 次の貼り付け先を選択(アクティブセルにする)[例:5個下のセル]
ActiveCell.Offset(5).Select
Set PIC = Nothing
Next i
' 終了
Application.ScreenUpdating = True
End Sub
よろしくおねがいします。
※マクロはほぼ初心者です。大体がネットからコピペをして使っている程度のレベルです。
No.1ベストアンサー
- 回答日時:
>①エクセルシートのA2,B2,C2,D2,A4,B4,C4,D4 …A24,B24,C24,D24セルに画像を挿入
>②マクロを開始するとフォルダを選ぶ画面が現れる
>③フォルダを選択すると、①にフォルダ内の画像がすべて貼り付けられる
>④画像は、セルの大きさに合わせて自動調整される
①は、A2で始まり、横に4進み、下に2進むという数列を設けています。
②は、ご存知のShell のBrowseForFolderを利用しましたが、他にもあるでしょう。
問題は③かな。一応、 ''安全のため(上限を設定) という箇所を設けましたが、不要なら、コメント・アウトしてください。また、DoEvents も入れておきました。
④は、何も手を付けていません。
コメント・アウトした部分で不要なら削除してください。
'//
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
WindFallerさま。
ご丁寧な回答をいただきましてありがとうございました!
おかげさまで希望通りのものができるようになり、とてもうれしく思います。
これで、作業効率が100倍UP!です。
プログラムの中身を見ましたが、全く意味が分かりませんでしたが、これを真似していろいろ工夫しほかにも有効活用させていただきます。
このたびはありがとうございました!
No.2
- 回答日時:
#1の回答者です。
成功してよかったです。
もう一つ、最近、こちらの掲示板でも同様の質問がちらほらでますが、
Pictures.Insert を使うと、
「画像のリンク情報が挿入され、肝心の画像が挿入されていない」
という問題が発生します。
つまり、Excelの画像を埋め込んだファイル自体を、他のPCで使う場合に起こる現象です。
その場合は、代わりに、
Shapes.AddPicture メソッドを使うようにします。
こちらを参考にしてください。
[AddPictureメソッドで画像を貼りつける]
http://www.moug.net/tech/exvba/0120020.html
WindFallerさま
ご提案いただきましたサイトに移動し試してみましたが、こちらは全くうまくいきませんでした。
最初の myFileName = ActiveWorkbook.Path & "\mogtan.gif"でつまづき、先に進みません。指定フォルダを選択するというプログラムに書き換えなければいけないのかと思い、色々やってみましたが、コピペで何とかなるレベルではないと悟りました。。
ちなみにですが、「ダブルクリックでセルに画像を貼りつける(Pictures.Insertメソッド)」というのがあったので、試してみましたが、メールで送付すると「リンクが切れてます」と出て自分のPC以外では画像が表示されないようでした。
重ね重ねの質問で申し訳ありませんが、これはどうしようもないのでしょうか?どこかを少し調整すると、メールで送付も可能となりますか?
ココにプログラムがありました。
http://www.moug.net/tech/exvba/0120027.html
ご面倒でなければ、お教えください。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
このQ&Aを見た人はこんなQ&Aも見ています
-
字面がカッコいい英単語
あなたが思う「字面がカッコいい英単語」を教えてください。
-
フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
あなたが普段思っている「これまだ誰も言ってなかったけど共感されるだろうな」というあるあるを教えてください
-
映画のエンドロール観る派?観ない派?
映画が終わった後、すぐに席を立って帰る方もちらほら見かけます。皆さんはエンドロールの最後まで観ていきますか?
-
海外旅行から帰ってきたら、まず何を食べる?
帰国して1番食べたくなるもの、食べたくなるだろうなと思うもの、皆さんはありますか?
-
天使と悪魔選手権
悪魔がこんなささやきをしていたら、天使のあなたはなんと言って止めますか?
-
Excel セルに入力した画像名からフォルダの画像を自動表示させたい
Excel(エクセル)
-
エクセルのセルに指定画像(.jpg)を自動で貼り付けたいです。
Excel(エクセル)
-
EXCELのVBAで画像を選んだ順に貼り付ける方法
Excel(エクセル)
-
-
4
VBAで選択した画像を貼り付けたい
Excel(エクセル)
-
5
エクセル フォルダの画像を画像名で検索して貼り付け
Excel(エクセル)
-
6
エクセルVBA 画像を貼り付けるセル位置を指定する方法
Excel(エクセル)
-
7
エクセル、画像ファイル名の書かれたセル(複数個所)に画像を一括で表示させる方法
Excel(エクセル)
-
8
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
-
9
複数の画像ファイルを挿入したい
Excel(エクセル)
-
10
エクセルのマクロで特定フォルダ内のJPGファイルを検索して開きたいので
Excel(エクセル)
-
11
任意フォルダから画像をすべてエクセルの指定マスに貼り付けをしたい
Visual Basic(VBA)
-
12
エクセル マクロ写真帳に一括で写真を張り付けたいです。
Visual Basic(VBA)
-
13
Excel 画像貼り付けのVBAについて
Excel(エクセル)
-
14
Excelで数字を入れたら対応する図を呼び出したい
Excel(エクセル)
-
15
マクロを実行すると画像がズレてしまいます
その他(Microsoft Office)
-
16
VBAエクセルに貼り付けた画像をセルにあった大きさにしたい(等倍)
Excel(エクセル)
-
17
【EXCEL VBA】ダブルクリックでセルのサイズに合わせて画像を挿入に機能を追加したいです。
Visual Basic(VBA)
-
18
【エクセルVBA】任意の画像フォルダから、画像を貼り付けしたいです。 下記、やりたい事のページを見つ
Excel(エクセル)
-
19
EXCELで別シートのセル内に画像の貼り付けをしたいのですが・・・
Excel(エクセル)
-
20
Excelの画像をセルとして参照する
Excel(エクセル)
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
【Excel VBA】指定行以降をクリ...
-
ExcelVBAを使って、値...
-
特定のセルが空白だったら、そ...
-
任意フォルダから画像をすべて...
-
Excel VBA マクロ ある列の最終...
-
VBA コピーして次の値まで貼り...
-
i=cells(Rows.Count, 1)とi=cel...
-
Application.Matchで特定行の検索
-
数字でピラミッドを出力させる...
-
DataGridViewの各セル幅を自由...
-
Excelのマクロについて
-
Excel VBA、 別ブックの最終行...
-
セル色なしの行一括削除
-
Excelのハイパーリンクにマクロ...
-
エクセルVBAでコピーして順...
-
Excel2003 複数セル1列の入力済...
-
Excelで指定した日付から過去の...
-
マクロ セルの値に応じてセルに...
-
特定の文字を条件に行挿入とそ...
-
セルの数式を集計個数の変動に...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
i=cells(Rows.Count, 1)とi=cel...
-
ExcelVBAを使って、値...
-
【Excel VBA】指定行以降をクリ...
-
特定のセルが空白だったら、そ...
-
EXCELで変数をペーストしたい
-
Excelで指定した日付から過去の...
-
VBAの間違い教えて下さい
-
【Excel】指定したセルの名前で...
-
Excelのプルダウンで2列分の情...
-
エクセルVBAでコピーして順...
-
Excel vbaで特定の文字以外が入...
-
Excel VBA、 別ブックの最終行...
-
【VBA】指定したセルと同じ値で...
-
特定の文字を条件に行挿入とそ...
-
TODAY()で設定したセルの日付...
-
screenupdatingが機能しなくて...
-
VBA初心者です。次のVBAコード...
-
指定した条件で行セルを非表示...
-
VBAでセルをクリックする回...
-
DataGridViewの各セル幅を自由...
おすすめ情報