[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『画像名を参照して自動で張り付けていく』（S１２１２）
1)現在の状況
http://sato001.com/excel-setpictures-class
を使用して仕事の写真の貼り付けを行っています。
2)問題点
上記サイトのマクロをEXCELに入れ非常に便利になりました。
しかしながら100枚(P1〜P100という名前)の写真があった際、不要なものをあらかじめ削除しなくてはならず少し不便に感じております。
3)行いたいこと
そこでこれを改良してA1セルにP1,B1セルにP３などと入れておき、それを参照して対応する写真を挿入できないかと考えています。
また、A35にP4,B35にP9などと入れ繰り返し写真を入れたいと考えています。（A４に２枚ずつ）
VBAの本を買っていろいろいじりましたが、素人なためVBAの理解がまだ十分ではなくうまくいきません。
何か道筋だけでもご教授いただければ幸いです。
＜ 使用 Excel：Excel2016、使用 OS：unknown ＞
＞また、A35にP4,B35にP9などと入れ繰り返し写真を入れたいと考えています。 「などと入れ繰り返し」は意味がよく分かりません。
(1) 写真を貼り付けるセルが固定されて規則性があり(A1,B1,A5,B5,A9,B9…など)、
そのセルには写真のファイル名以外の文字が入力されることがない場合は、
1) 写真を貼り付ける予定のセルに書き込んだファイル名を抽出し、
2) 写真帳の上から貼付け順に一覧表に書き出し、
3) 一覧表の順にファイル名を指定して貼付ける
の手順で、ネット上にあるマクロを少し変更するだけで可能だと私は思います。
一覧表のイメージ
FileName Address
1 P1 A1
2 P3 B1
3 (空欄) A5
4 P2 B5
5 P10 A9
6 P5 B9
※一覧表は作成しなくてもできますが、作成する方が楽だと思います。
※「一覧表」はイメージであって実際には作らなくても処理できます。
※アドレスは(1)の場合不要、次の(2)のための参考イメージです。
(2) 全く任意のセルに写真ファイル名を入れて貼り付ける場合も、 各セルごとに、写真ファイル名と貼るセルのアドレスを持たせればできるのですが、 全てのセルについて「入力されている値・文字が写真ファイルかどうか」を判定し、 一覧表を作成するところが難しくなってくるように私は思います。 また写真ファイルの命名規則はその都度変わる可能性があるので大変ではないかと思います。
（NN） 2018/02/26(月) 23:17
繰り返しの部分ですがx行飛ばしで同じマクロ(写真番号を参照して貼り付け)を行いたいという意味でした。
言葉足らずで申し訳ありませんでした。
（S1212） 2018/03/02(金) 19:55
私は、検討されている写真の貼付け方法は決して効率的な方法であるとは思いませんが、 次の簡単なマクロで実現は出来ると思います。 (1)写真台紙の写真を貼り付ける位置を見つけては、 (2)そのセルに書かれたファイル名を引数として下のマクロ(SetAlbum)を実行する。 これで終わりです。 前段の「写真台紙の写真を貼り付ける位置を見つける」部分のマクロの方が大変だと思います。
本体はSetAlbumだけ。ファイル名が分かっていれば本当に簡単なマクロなんです。 FIleNameTableはテスト用に、フォルダ内のファイルの一覧を書き出すものです。 とりあえず、セルのダブルクリックで動かしてみてください。 (1) FIleNameTableを実行してフォルダ内の写真の一覧表をシートに書き出す。 (2) 書き出したファイル名のセルをつまんで、適当な位置に動かし (3) そのセルをダブルクリックする。
[シートモジュール]
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim myFName As String
myFName = Range("A1") & ActiveCell.Value
Call Module1.SetAlbum(myFName)
Cancel = True
End Sub
[標準モジュール]
Option Explicit
Sub SetAlbum(ByRef myFName As String)
Dim IntMsg As Integer
Dim pic As Variant
On Error Resume Next
If Dir(myFName) <> "" Then 'ファイルの存在確認
Set pic = ActiveSheet.Pictures.Insert(myFName)
With pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMove
End With
With pic.ShapeRange
.LockAspectRatio = msoTrue
.Width = 250 '写真の横幅を指定
'.Height = 175'写真の鷹さを指定する場合はこちら
End With
Set pic = Nothing
Else
'写真ファイルが無ければメッセージ(確認→中止)
MsgBox myFName & vbCrLf & "が存在しません"
End If
End Sub
Sub FIleNameTable()
Dim FolName
Dim eRow As Long
Dim eCol As Long
Dim buf As String, cnt As Long
Const StRow As Long = 2
On Error Resume Next
'ファイル一覧を作成
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "写真保存先フォルダ選択"
.InitialFileName = ThisWorkbook.Path
If .Show = True Then
FolName = .SelectedItems(1)
Else
Exit Sub
End If
End With
If Right$(FolName, 1) <> "\" Then FolName = FolName & "\"
Application.ScreenUpdating = False
'作表エリアをクリア
eRow = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
eCol = ActiveSheet.UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
If eRow < StRow Then eRow = StRow
Range(Cells(StRow, 2), Cells(eRow, eCol)).Select
Selection.ClearContents
Range("A1").Value = FolName
buf = Dir(FolName & "\" & "*.*")
cnt = 1
Do While buf <> ""
cnt = cnt + 1
Cells(cnt, 1) = buf
buf = Dir()
Loop
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Range("A1").Select
End Sub
考えられている方法は、アクセスの写真ファイルの管理などで行われており、 別の使い方をすると面白い方法なんですがね。 （ NN） 2018/03/02(金) 20:28
SetAlbumのマクロ教えていただきありがとうございました。
上記マクロの件ですが200枚以上写真を入れていく作業を行うので少し不便かなと思いました。
（２００行の中から選択し、それを例えば50行ごとに入れていく作業の際など）
ここ数日考えていましたが良さそうな案がいくつか浮かんできました。
（私にマクロ化できるかわかりませんが......）
色々といじってみようかと思っております。
（s1212） 2018/03/04(日) 13:38
セルにファイル名を入力した瞬間に写真を貼ることはできますから、 後からまとめて貼るメリットは 作業途中でのファイルサイズを小さくして保存や開く動作が速くなることくらいですからね。 写真の貼付け作業の効率化の一つは「ファイルの命名規則」を検討することですよ。 以上 （ NN） 2018/03/04(日) 23:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.