Excelを用いコンタクトシートのような配列で
画像を挿入(複数)させるマクロを作成したいのですが
「縦5枚×横3枚」のような配列にする時に
「横3枚」挿入させる方法がわかりません。
ご教授お願い申し上げます。
Q:下記のような配列で画像を挿入するには?
-------------------------------------------
A B C D E F
1 01.jpg 02.jpg 03.jpg
2
3 04.jpg 05.jpg 06.jpg
4
5 07.jpg 08.jpg 09.jpg
6
7 10.jpg 11.jpg 12.jpg
8
9 13.jpg 14.jpg 15.jpg
10
---次ページ---
11 16.jpg 17.jpg 18.jpg
12
13 19.jpg 20.jpg 21.jpg
14
15 22.jpg 23.jpg 24.jpg
16
17 25.jpg 26.jpg 27.jpg
18
19 28.jpg 29.jpg 30.jpg
20
---次ページ---
21 31.jpg 32.jpg 33.jpg
22
23 34.jpg 35.jpg 36.jpg
24
25 37.jpg 38.jpg 39.jpg
・
・
・
・
-------------------------------------------
※画像挿入のマクロに関してはこちら↓の質問を参考にしています。
質問番号:4676078
「エクセルで写真挿入 マクロ」
http://oshiete1.goo.ne.jp/qa4676078.html
※画像はJPG形式に限りません。(BMP、GIF等も)
※コンタクトシート作成ソフトは使いませんので
必ずExcelでマクロを使用する方法をご回答願います。
No.2ベストアンサー
- 回答日時:
ご提示のコードだと、スタートセル(C4)から順に次のセルを決めて行く方式ですので、わざわざ行・列を計算しなくても、次のセルの位置を指定すればよくなっていますね。
現在のセルに対して次のセルは、基本的には右へ2列なので
ActiveCell.Offset(0,2).Select
となりますし、もし現在のセルがE列より右なら(折り返すので)
ActiveCell.Offset(2,-4).Select
みたいになります。
両方を合わせれば
If ActiveCell.column>5 then ActiveCell.offset(0,2).select else AitiveCell.Offset(2,-4).select
で次のセルが決まるのでは?
この回答への補足
ご回答ありがとうございます。
詳しいご回答を頂いたのですが、コードをうまく実行できず
「横3枚」まで行かず、「横2枚」で折り返してしまいます。
何度も申し訳ございませんが、現在は以下のコードとなっていますので
再度ご教授お願い申し上げます。
Sub 複数の画像を挿入()
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)
' 貼り付け開始セルを選択
'ActicveCellRange("B4").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
' 次の貼り付け先を選択(アクティブセルにする)[例:6個下のセル]
Select Case i Mod 2
Case 1 '奇数回目
ActiveCell.Offset(0, 2).Select
Case 0 '偶数回目
ActiveCell.Offset(9, -2).Select
End Select
Set PIC = Nothing
Next i
' 終了
Application.ScreenUpdating = True
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation
End Sub
' バブルソート(文字列)
Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)
If Not IsArray(Source) Then Exit Sub
Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
If StrComp(Source(IIf(SortAsc, j, j + 1)), _
Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
vntTmp = Source(j)
Source(j) = Source(j + 1)
Source(j + 1) = vntTmp
End If
Next j
Next i
End Sub
補足
【使用環境】
Microsoft Windows XP Professional
Microsoft Office Excel 2003 SP3
Microsoft Visual Basic 6.5
No.1
- 回答日時:
例えば全体をループで回していると仮定して、i番目の画像をどこに配置するかを対応できれば良いですよね?
質問文に合わせるなら、列はB、D、Fの順(偶数列)、行は1、3、5(奇数行)…が対象となっているとして
i のループが1から始まると仮定すれば、i番に対応する行番号、列番号は
行番号 = Int((i - 1) / 3) * 2 + 1
列番号 = ((i - 1) Mod 3 + 1) * 2
で求められますので、そこに貼り付けるようにすればよいのでは?
(iのスタートを0からにする方が、対応式は簡単になります)
逆に、行番号、列番号から対応するインデックス番号(=i)を求めるには
i = ((rw-1)*3+col)/2 (rw:行番号、col:列番号)
となります。
対象となる行や列が違う場合でも、対応関係が規則的なら読み替えの式が作成できるはずですので、このような式を元に対応させてゆくのが簡単化と思います。
この回答への補足
ご回答頂きありがとうございました。
大変お恥ずかしい話ですが、ご教授頂いたコードを
どの位置に貼り付ければ良いのか検討がつきません。
お手数をお掛けして申し訳ございませんが
下記のコードに当てはめご回答頂ければ頂けれ幸いです。
宜しくお願い申し上げます。
Sub 複数の画像を挿入()
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)
' 貼り付け開始セルを選択
'ActicveCellRange("C4").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
MsgBox i - 1 & "枚の画像を挿入しました", vbInformation
End Sub
' バブルソート(文字列)
Private Sub BubbleSort_Str( _
ByRef Source As Variant, _
Optional ByVal SortAsc As Boolean = True, _
Optional ByVal Compare As VbCompareMethod = vbTextCompare)
If Not IsArray(Source) Then Exit Sub
Dim i As Long, j As Long
Dim vntTmp As Variant
For i = LBound(Source) To UBound(Source) - 1
For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
If StrComp(Source(IIf(SortAsc, j, j + 1)), _
Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
vntTmp = Source(j)
Source(j) = Source(j + 1)
Source(j + 1) = vntTmp
End If
Next j
Next i
End Sub
ご回答頂きありがとうございました。
その後いろいろ試行しながら貼り付け先を調整して
無事に解決しました。
ありがとうございました。
(入力欄が前後してしまい申し訳ございません。)
' 次の貼り付け先を選択(アクティブセルにする)
Select Case i Mod 3
Case 2
ActiveCell.Offset(0, 2).Select
Case 1
ActiveCell.Offset(0, 2).Select
Case 0
ActiveCell.Offset(9, -5).Select
End Select
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
このQ&Aを見た人はこんなQ&Aも見ています
-
あるあるbotに投稿したけど採用されなかったあるある募集
あるあるbotに投稿したけど採用されなかったあるあるをこちらに投稿してください
-
フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
あなたが普段思っている「これまだ誰も言ってなかったけど共感されるだろうな」というあるあるを教えてください
-
映画のエンドロール観る派?観ない派?
映画が終わった後、すぐに席を立って帰る方もちらほら見かけます。皆さんはエンドロールの最後まで観ていきますか?
-
海外旅行から帰ってきたら、まず何を食べる?
帰国して1番食べたくなるもの、食べたくなるだろうなと思うもの、皆さんはありますか?
-
天使と悪魔選手権
悪魔がこんなささやきをしていたら、天使のあなたはなんと言って止めますか?
-
エクセルのマクロでコンタクトシートを作成したいです
Visual Basic(VBA)
-
A4の用紙に写真をたくさん並べてファイル名も印刷する方法
Windows 10
-
エクセルで写真挿入 マクロ
Word(ワード)
-
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
[EXCEL]ボタン押す→時刻が表に...
-
エクセルで特定の文字列が入っ...
-
罫線の斜線を自動で引くマクロ
-
エクセル マクロ オートフィ...
-
エクセル マクロで数値が変っ...
-
特定の文字がある行以外を削除...
-
Excel グラフのプロットからデ...
-
エクセルのセルに指定画像(.jpg...
-
Excel ウインドウ枠の固定をす...
-
エクセルVBAのEntireRow.Hidden...
-
【Excel関数】UNIQUE関数で"0"...
-
エクセル マクロ等を利用した各...
-
excel 小さすぎて見えないセル...
-
エクセル 上下で列幅を変えるには
-
Excel2007で、指定範囲の行高さ...
-
AのセルとB行を比較して、一致...
-
直近の5個の平均を求めたい
-
エクセルのマクロで意図しない...
-
excelのデータで色つき行の抽出...
-
Val関数をVBAで使うには?
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
エクセルで特定の文字列が入っ...
-
[EXCEL]ボタン押す→時刻が表に...
-
エクセル 上下で列幅を変えるには
-
特定の文字がある行以外を削除...
-
【Excel関数】UNIQUE関数で"0"...
-
VBAで色の付いているセルの行削除
-
Excel グラフのプロットからデ...
-
エクセル マクロ オートフィ...
-
エクセル マクロで数値が変っ...
-
エクセルのセルに指定画像(.jpg...
-
結合されたセルをプルダウンの...
-
AのセルとB行を比較して、一致...
-
罫線の斜線を自動で引くマクロ
-
excel 小さすぎて見えないセル...
-
excelのデータで色つき行の抽出...
-
Excel2007で、指定範囲の行高さ...
-
サイズの違うセル 並べ変え
-
エクセル 時間の表示形式AM/PM...
-
エクセルマクロで偶数行(又は...
-
A1に入力された文字列と同じ文...
おすすめ情報