ここから本文です

エクセル【VBA】 複数シートに写真を挿入する方法を教えてください

ens********さん

2009/7/2215:55:27

エクセル【VBA】 複数シートに写真を挿入する方法を教えてください

シート[入力]
写真左 写真右
photo1_Left photo1_Right
photo2_Left photo2_Right
photo3_Left photo3_Right
photo4_Left photo4_Right
photo5_Left photo5_Right

photo20_Left photo20_Left

同一ブック内にはシート[入力]以降、シート[1][2][3][4][5]…[20]とあります。

シート[1]~[20]は全て同じ形式で、シート[1]のA1に別フォルダ[image]内にあるphoto1_Left.jpgファイルを、A2には[image]内にあるphoto1_Right.jpgファイルを挿入し、以降シート[2]~[20]にも同様に写真データを挿入するにはどのようなコードを組めばよいのでしょうか?

どなたかご教授いただきますようお願いいたします。

閲覧数:
2,270
回答数:
2
お礼:
50枚

違反報告

ベストアンサーに選ばれた回答

mek********さん

編集あり2009/7/2220:32:14

一案


Sub LoadPicTest()

Dim Ws As Worksheet
Dim Fname As Variant, LR As String
Dim Pic As Picture

On Error Resume Next
Application.ScreenUpdating = False

For Each Ws In ThisWorkbook.Worksheets
If Ws.Name = "入力" Then GoTo jump
Ws.Activate
' シ-ト名が[シ-ト1]の場合 ↓ Sheet1 の場合は ⇒ Sheet
N = Val(Replace(Ws.Name, "シ-ト", ""))

For Each Pic In Ws.Pictures
Pic.Delete
Next

' セルの高さ=画像の縦(の最大値)を指定 ↓ 仮設定
Rows("1:2").RowHeight = 60
Range("A1").Select

For i = 1 To 2

If i = 1 Then
LR = "Left"
ElseIf i = 2 Then
LR = "Right"
End If
' ドライブ + フォルダ-名 + ファイル名 ↓
Fname = "D:\Image\photo" & N & "_" & LR & ".jpg"
Set Pic = Ws.Pictures.Insert(Fname)
' ファイル名 ↓ 確認表示用
' Cells(i, 2).Value = Fname

If Pic.Height > Pic.Width Then
GoTo PicH
ElseIf Pic.Height < Pic.Width Then
GoTo PicW
End If

PicH:
With Pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMove
End With
With Pic.ShapeRange
.LockAspectRatio = msoTrue
.Height = ActiveCell.Height
End With
If Pic.Width > ActiveCell.Width Then
GoTo PicW
Else
End If
GoTo Center

PicW:
With Pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMove
End With
With Pic.ShapeRange
.LockAspectRatio = msoTrue
.Width = ActiveCell.Width
End With
If Pic.Height > ActiveCell.Height Then
GoTo PicH
Else
End If
Set Fname = Nothing

Center:
aw = ActiveCell.Width
bw = Pic.Width
x = (aw - bw) / 2
Pic.Left = ActiveCell.Left + x

ah = ActiveCell.Height
bh = Pic.Height
y = (ah - bh) / 2
Pic.Top = ActiveCell.Top + y


ActiveCell.Offset(1).Select

Set Pic = Nothing
Next i
Ws.Range("A1").Select
jump:
Next Ws

End Sub



シ-ト名の詳細(半角全角の違い、その他)や
表示セルの高さ、
画像保存ドライブ + フォルダ-パス
等、の条件面で、不確かな点がありましたので、
当方の仮設定で、コ-ドは作成しております。

シ-ト名が[入力]の場合は、
処理をいたしません。

単純に、A1 および A2 セルに、
画像を挿入した場合、とても小さな画像となります。

また、元の画像サイズに合わせる方法とりますと、
元画像が、大きい場合、
セルの高さが、同一行の他のセルにその影響を、
与えると思われます。⇔ セル単位、列単位での設定が難しい為

........ 横長の画像、縦長の画像の場合、セルからのはみ出しを、
........ 抑止する必要があります。

この点に、ついても、お考えやご希望などありましたら、
[補足]で、お知らせ頂けないでしょうか。

なお、上記コ-ドは、
元画像の縦横比を維持、
画像をセルの中央に配置します。
...... コ-ドの実行の際に、前の画像をクリアします。
...... ↑ 画像の重複挿入を回避する為


▽ セルの高さの変化をなくす、別の方法例 ▽

各シ-トに、
結合セルを、必要個数用意して、
結合セル内に画像を挿入する方法や、

オ-トシェ-プを、必要個数挿入し、
オ-トシェ-プをクリックした時点で、オ-トシェ-プ内に、
画像を挿入する方法なども、考えられますので、
ご検討ください。

この回答は投票によってベストアンサーに選ばれました!

ベストアンサー以外の回答

1〜1件/1件中

kaz********さん

2009/7/2218:09:26

フォルダ名を設定して試してみて
写真の高さはお好きな数字に。

Sub test()
Dim 写真1 As Picture
Dim 写真2 As Picture
Dim Leftファイル名 As String
Dim Rightファイル名 As String
Dim 写真のフォルダ As String
Dim 番号 As Integer
Dim シート名 As Worksheet

Dim 写真高さ As Long
写真高さ = 200
For 番号 = 1 To 20
Leftファイル名 = "photo" & 番号 & "_Left.jpg"
Rightファイル名 = "photo" & 番号 & "_Right.jpg"
写真のフォルダ = "D:\マイ ドキュメント\" ’ココにフォルダ名

Set シート名 = Worksheets(CStr(番号))
Set 写真1 = シート名.Pictures.Insert(写真のフォルダ & Leftファイル名)
Set 写真2 = シート名.Pictures.Insert(写真のフォルダ & Rightファイル名)
With 写真1.ShapeRange
.Left = シート名.Range("A1").Left
.Top = シート名.Range("A1").Top
.LockAspectRatio = msoTrue
.Height = 写真高さ
シート名.Range("A1").RowHeight = .Height
シート名.Range("A1").ColumnWidth = .Width / 6
End With
With 写真2.ShapeRange
.Left = シート名.Range("A2").Left
.Top = シート名.Range("A2").Top
.LockAspectRatio = msoTrue
.Height = 写真高さ
シート名.Range("A2").RowHeight = .Height
シート名.Range("A2").ColumnWidth = .Width / 6
End With
Next
End Sub

あわせて知りたい

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる