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でマクロを使用する方法をご回答願います。

このQ&Aに関連する最新のQ&A

A 回答 (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

補足日時:2009/05/27 11:23
    • good
    • 0
この回答へのお礼

補足

【使用環境】
Microsoft Windows XP Professional
Microsoft Office Excel 2003 SP3
Microsoft Visual Basic 6.5

お礼日時:2009/05/27 12:01

例えば全体をループで回していると仮定して、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

補足日時:2009/05/26 18:36
    • good
    • 0
この回答へのお礼

ご回答頂きありがとうございました。
その後いろいろ試行しながら貼り付け先を調整して
無事に解決しました。
ありがとうございました。
(入力欄が前後してしまい申し訳ございません。)


' 次の貼り付け先を選択(アクティブセルにする)
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

お礼日時:2009/05/27 19:38

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセルのマクロでコンタクトシートを作成したいです

はじめまして、
タイトルの通り、エクセルのマクロでコンタクトシートを作成したく質問しました。

コンタクトシートの内容としては、
●フォルダ内にある画像(今回の場合はPNG)すべてを一覧リスト化する(A列)。
●A列に配置された画像の情報(ファイル名、画像サイズ等)をB列以降に表示。
の以上がやりたい事です。

  A列   B列    C列
1 画像 ファイル名 画像サイズ
2 画像 ファイル名 画像サイズ
3 画像 ファイル名 画像サイズ
       ・
       ・
       ・
と、続く様な表示にしたいです。

できれば、
A列の画像は、セルにあわせてしまうと小さく表示されてしまうようなので、
・元の画像の50%などといったように表示される?
・またはセルのサイズの最大値(50px x 50px)を固定する?
のようになると、とてもありがたいです。

他の質問等を探してみましたが、
photoshopでのコンタクトシートは求めているものと違いました。
また、エクセル等での回答がありましたが、画像のみの表示でしたので、
上記の様な事が1度にできればと思い、ココに質問させていただきました。

知識レベルとしては、
マクロ初心者です。

どうか みなさんの知識をお借りしたいと思いますので、
よろしくお願いいたします。

pc環境:
windows XP
Excel 2000

はじめまして、
タイトルの通り、エクセルのマクロでコンタクトシートを作成したく質問しました。

コンタクトシートの内容としては、
●フォルダ内にある画像(今回の場合はPNG)すべてを一覧リスト化する(A列)。
●A列に配置された画像の情報(ファイル名、画像サイズ等)をB列以降に表示。
の以上がやりたい事です。

  A列   B列    C列
1 画像 ファイル名 画像サイズ
2 画像 ファイル名 画像サイズ
3 画像 ファイル名 画像サイズ
       ・
       ・
       ・
と、...続きを読む

Aベストアンサー

Sub Pict_Addは、A列にPNG画像、B列にファイル名、C列に画像サイズ、D列に画像作成日 を表示させるサンプルです。
以下は、標準モジュールにコピペしてください。
下記マクロを実装したエクセルのファイルは、必ずPNG画像を置いてあるフォルダーに保存してください。
保存してから実行してください。
Sub Pict_Deleteは、表示されたデータを消去するマクロです。

Sub Pict_Add()
  Dim myPic As Shape, myC As Range, i As Long
  Cells.RowHeight = 50
  Columns(1).ColumnWidth = 8.38
  With Application.FileSearch
    .NewSearch
    .LookIn = ThisWorkbook.Path
    .SearchSubFolders = False
    .Filename = "*.png"
    If .Execute() > 0 Then
      For i = 1 To .FoundFiles.Count
        Set myC = ActiveSheet.Range("A" & i)
        Set myPic = ActiveSheet.Shapes.AddPicture _
        (.FoundFiles(i), msoTrue, msoFalse, myC.Left, myC.Top, myC.Width, myC.Height)
        myC.Offset(0, 1).Value = Dir(.FoundFiles(i))
        myC.Offset(0, 2).Value = FileLen(.FoundFiles(i))
        myC.Offset(0, 3).Value = FileDateTime(.FoundFiles(i))
      Next i
    End If
  End With
  Rows(i & ":" & Rows.Count).AutoFit
  Columns("B:D").EntireColumn.AutoFit
End Sub

Sub Pict_Delete()
  Dim myPic As Shape
  For Each myPic In ActiveSheet.Shapes
    If myPic.Type = msoLinkedPicture Then
      myPic.Delete
    End If
  Next
  Columns("B:D").ClearContents
End Sub

Sub Pict_Addは、A列にPNG画像、B列にファイル名、C列に画像サイズ、D列に画像作成日 を表示させるサンプルです。
以下は、標準モジュールにコピペしてください。
下記マクロを実装したエクセルのファイルは、必ずPNG画像を置いてあるフォルダーに保存してください。
保存してから実行してください。
Sub Pict_Deleteは、表示されたデータを消去するマクロです。

Sub Pict_Add()
  Dim myPic As Shape, myC As Range, i As Long
  Cells.RowHeight = 50
  Columns(1).ColumnWidth = 8.38
  With Applica...続きを読む

Qエクセルのリストに図を挿入した場合の、オートフィルタでの並べ替えについて

現在仕事で、エクセルでリストを作っています。
そのリストには、図もはめ込まなくてはならないのですが、
このリストをオートフィルタ機能で並べ替えようとすると
大変なことになってしまいます・・・。

たとえば、ひとつの商品分類『チョコレート』を選択して
オートフィルタで抽出すると、各社のチョコレート一覧が
出てきます。その隣りに、チョコレートのパッケージの図が
それぞれ表示されるはずなのですが、他の関係ない商品
(たとえば、飴類、スナック類など)のパッケージの図が
全て折り重なって残ってしまうのです。

こうならないように、エクセルのセルに完全に図をはめ込む
(一体化させる)ことはできないでしょうか?

セルと図形をグループ化できないかと思いましたが、それは
できないようでした・・・。また、ツール-オプション-編集で、
『オブジェクトをセルとともに切り取り、並べ替える』に
チェックを入れてもダメでした・・・。

どなた様か、よい方法をご存知の方がいらっしゃいましたら、
お教え頂けると大変助かります。
何卒、宜しくお願い申し上げます。

現在仕事で、エクセルでリストを作っています。
そのリストには、図もはめ込まなくてはならないのですが、
このリストをオートフィルタ機能で並べ替えようとすると
大変なことになってしまいます・・・。

たとえば、ひとつの商品分類『チョコレート』を選択して
オートフィルタで抽出すると、各社のチョコレート一覧が
出てきます。その隣りに、チョコレートのパッケージの図が
それぞれ表示されるはずなのですが、他の関係ない商品
(たとえば、飴類、スナック類など)のパッケージの図が
全て折り重...続きを読む

Aベストアンサー

こんにちは。

印刷用途なら、とりあえず...

1. 画像をセルに完全に納める
  セル枠からはみ出さず、セルサイズより一回り小さくして、中心位置
  に配置する

2. 図の上で右クリック、[図の書式設定]-[プロパティー]-
  [セルに合わせて移動やサイズを変更する]

としてみたらどうなりますか? もちろん、[ツール]-[オプション]-[編集]の

> 『オブジェクトをセルとともに切り取り、並べ替える』

にはチェックを入れておきます。


表示上のみの問題ならコメントを活用してみるのも手です。

コメントもシェープの一種ですから、塗りつぶし効果で画像を表示させる
ことができます。コメントなので並べ替え、フィルタ等に影響されません。
つまり、通常は見えない状態ですが、セルにカーソルをあてるとコメント
の様に画像がポップアップ表示されるという仕組みです。

ご参考までに。

Q写真(絵)のサムネイルをプリントアウトしたい!

フォルダ内の、すべての写真(絵)のサムネイルを一度にプリントアウトしたいのですが、どうしたらできますか?

ご教授おねがいします。

Aベストアンサー

>Ctrl + A は、ただファイルを全部選択しただけだと思います。
はい、それでいいんです。

Ctrl + Aでファイルを全選択
適当な画像を右クリック。
「印刷」ボタンをクリック。

右側のほうに「フルページ写真」などの選択肢があるので、一番下の「コンタクトシート(35)を選択。
これで用紙1枚当たりの35枚のサムネールが印刷できます


人気Q&Aランキング

おすすめ情報