[[20120211132623]]　『指定した数字を入力するとイラストが挿入される方』（コンドウ）　ページの最後に飛ぶ

『指定した数字を入力するとイラストが挿入される方法』（コンドウ）

 ①JPEGで作成したイラストがあり、指定した数字を入力すると、イラストが挿入される方法を教えてください。
 ②指定した数字をクリアにするとイラストも削除される方法を教えてください。

 イラスト名前は　「007  文字」・「030　文字」などとなっています。
 イラストサイズは、高さ4.71cm　幅5.4cmです。
　JPEGのイラストが入っている場所は「マイ ドキュメント」の「イラスト」フォルダに入っています。

      A　 　B　　   C　   　D　　   E　      F
  3         7  　   30      5       8        116       
  4         24      64      73      93       33 
  5         9       33      20      50       15
  6         120     125     66      124      56
  7         106     38      28      25       40
  8         161     180     140     155      172

 ※B3に7を入れるとA14：E22の範囲でイラストが挿入（B3＝A14：E22）
　 他は下記の通りです。
  　　　　　　　　　 C3＝G14：K22 　、　D3＝M14：Q22　、　E3＝Y14：AC22
　 B4＝A26：E34　、　C4＝G26：K34　 、  D4＝M26：Q34　、　E4＝Y26：AC34
　 B5＝A37：E45　、　C5＝G37：K45　 、  D5＝M37：Q45　、　E5＝Y37：AC45
　 B6＝A48：E56　、　C6＝G48：K56　 、  D6＝M48：Q56　、　E6＝Y48：AC56
　 B7＝A59：E67　、　C6＝G59：K67　 、  D6＝M59：Q67　、　E6＝Y59：AC67
　 B8＝A70：E78　、　C6＝G70：K78　 、  D6＝M70：Q78　、　E6＝Y70：AC78

 よろしくお願いします。m(__)m

 イラストのファイル名は、たとえば　7 だったら　007ABCD.jpeg とか？
 フォルダ内に007からはじまる画像が複数あったら、先がちでいいのかな？

 追記）それと、セルに入力されたタイミングで画像を挿入、ないしは（空白なら）削除でいいのかな？
　　（すでにセルに数字が書き込まれていても、セルが変更されるまでは何もしなくてもいい？）

 (ぶらっと)

 ① たとえば　7 だったら　007ABCD.jpeg とか？　←　「007 机.jpeg」「030 椅子.jpeg」です。数字と文字の間に半角スペースが入っています。
 ② 007からはじまる画像が複数あったら　←　007は一つだけです。複数は存在しません。
 ③ すでにセルに数字が書き込まれていても、セルが変更されるまでは何もしなくてもいい？）←そのままでいいです。

 よろしくお願いします。（コンドウ）m(__)m

 E列の数字に対する貼り付け先が、A～D列の数字の貼り付け先とくらべ列番号の規則が不一致だけど、いいの？

 それと、貼り付け先は結合セルということじゃないんだね。

 あと、画像は貼り付け先領域の左上隅にあわせて、そのまま貼り付けるだけでいいの？
それとも、画像の縦横比率も考慮し、同じ比率で、かつ貼り付け先領域をはみださないようにする？
（必要なら拡大も？）

 追記）　貼り付け先領域の行番号の規則も、3->14 4->26 で　差が12 だけど、4行目以降については差が11。これもいいのかな？

 (ぶらっと)

 とりあえず｢不規則な貼り付け先｣という前提で。
なお、領域をはみだす場合は縮小しているけど、領域に収まった場合の拡大はしていない。
 (アップ後、コード一部訂正 さらに0:09 訂正）

 シートモジュールに。

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim picName As String
    Dim fName As String
    Dim myPath As String
    Dim n As Long
    Dim myR As Range

    If Target.Count > 1 Then
        MsgBox "複数セルへの入力はサポートしていません" & vbLf & "入力を取り消します"
        Application.EnableEvents = False
        Application.Undo
        Application.EnableEvents = True
        Exit Sub
    End If

    If Intersect(Target, Range("B3:E8")) Is Nothing Then Exit Sub

    picName = "myPic_" & Target.Address(False, False)
    If IsObject(Evaluate(picName)) Then Me.Shapes(picName).Delete
    If Len(Target.Value) = 0 Then Exit Sub

    myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\イラスト\"

    fName = Dir(myPath & "*.jpeg")

    Do While Len(fName) > 0
        n = Val(fName)
        If n = Target.Value Then
            Set myR = GetCell(Target)
            With Me.Pictures.Insert(myPath & fName)
                .Top = myR.Top
                .Left = myR.Left
                .Name = picName
                If .Width > myR.Width Then .Width = myR.Width
                If .Height > myR.Height Then .Height = myR.Height
            End With
            ActiveCell.Activate
            Exit Do
        End If
        fName = Dir()
    Loop

    If Len(fName) = 0 Then MsgBox Target.Value & "に紐ついた画像ファイルがありません"

 End Sub

 Private Function GetCell(Target As Range) As Range
    Dim y As Long, x As Long

    If Target.Column = 5 Then
        x = 25 'Y列
    Else
        x = (Target.Column - 2) * 6 + 1
    End If

    If Target.Row = 3 Then
        y = 14   '14行目
    Else
        y = (Target.Row - 4) * 11 + 26
    End If

    Set GetCell = Cells(y, x).Resize(9, 5)

 End Function

 (ぶらっと)

 ①E列の数字に対する貼り付け先が、A～D列の数字の貼り付け先とくらべ列番号の規則が不一致だけど、いいの？ ←　間違っていました。
 ② 追記）貼り付け先領域の行番号の規則も、3->14 4->26 で　差が12 だけど、4行目以降については差が11。これもいいのかな？  ← 気づきませんでした(^_^;)。
 <正しいは下記の通りでお願いしますm(__)m　>
 B4＝A15：E22　、　C3＝G15：K22 　、　D3＝M15：Q22　、　E3＝S15：W22  、　F3＝Y15：AC22
 B4＝A26：E33　、　C4＝G26：K33　 、  D4＝M26：Q33　、　E4＝S26：W33  、　F4＝Y26：AC33
 B5＝A37：E44　、　C5＝G37：K44　 、  D5＝M37：Q44　、　E5＝S37：W44  、　F5＝Y37：AC44
 B6＝A48：E55　、　C6＝G48：K55　 、  D6＝M48：Q55　、　E6＝S48：W55　、　F6＝Y48：AC55
 B7＝A59：E66　、　C6＝G59：K66　 、  D6＝M59：Q66　、　E6＝S59：W66　、　F6＝Y48：AC66
 B8＝A70：E78　、　C6＝G70：K78　 、  D6＝M70：Q78　、　E6＝S70：W78　、　F6＝Y48：AC78
 ※1つのセル幅は （ 横は4.50(41ピクセル)　、縦は13.50(18ピクセル） ）です。

 ②貼り付け先は結合セルということじゃないんだね。 ←　今現在は結合セルになっていませんが、はみだすのであれば結合セルでもいいです。
 ③画像は貼り付け先領域の左上隅にあわせて、そのまま貼り付けるだけでいいの？　←　左上隅にあわせて、貼り付けるだけでいいです。
 ④画像の縦横比率も考慮し、同じ比率で、かつ貼り付け先領域をはみださないようにする？　←　すべての画像が同じ比率で、はみださないようにお願いします。
 ⑤Do While Len(fName) > 0
        n = Val(fName)
        If n = Target.Value Then
            Set myR = GetCell(Target)　←　Target　コンパイルエラー　「ByRef 引数の型が一致しません。」と表示します。

よろしくお願いします。（コンドウ）m(__)m

 レイアウトの訂正ならびに、他の希望要件了解。
今、時間がとれないので、コンパイルエラーの件（おかしいなぁ・・・）とあわせて、少し時間ちょうだいね。

 (ぶらっと)

  (ぶらっと)さん、忙しい時に質問してすいません。m(__)m 
 少し時間ちょうだいね。 ← はい、わかりました。
 お手数をお掛けいたしますが、よろしくお願いします。（コンドウ）m(__)m

 以下を試してみて。
サブプロシジャのGetCellは廃止。あわせて、コピペ入力等、あるいは複数セル選択のクリア等　複数セル同時入力サポート。
(もし、環境が2007以降なら、すこし直した方がいいところもあるけど）

シートモジュールに

 Private Sub Worksheet_Change(ByVal Target As Range)
    Dim picName As String
    Dim fName As String
    Dim myPath As String
    Dim n As Long
    Dim myO As Range
    Dim myR As Range
    Dim c As Range

    Set myO = Intersect(Target, Range("B3:E8"))
    If myO Is Nothing Then Exit Sub
    myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\イラスト\"

    For Each c In myO

        picName = "myPic_" & c.Address(False, False)
        If IsObject(Evaluate(picName)) Then Me.Shapes(picName).Delete
        If Len(c.Value) > 0 Then

            fName = Dir(myPath & "*.jpeg")

            Do While Len(fName) > 0

                n = Val(fName)
                If n = c.Value Then
                    Set myR = Cells((c.Row - 3) * 11 + 15, (c.Column - 2) * 6 + 1).Resize(8, 5)

                    With Me.Pictures.Insert(myPath & fName)
                        .Top = myR.Top
                        .Left = myR.Left
                        .Name = picName
                        If .Width > myR.Width Then .Width = myR.Width
                        If .Height > myR.Height Then .Height = myR.Height
                    End With

                    Exit Do

                End If

                fName = Dir()

            Loop

            If Len(fName) = 0 Then MsgBox c.Value & "に紐ついた画像ファイルがありません"

        End If

    Next

    ActiveCell.Activate

    Set myR = Nothing
    Set myO = Nothing

 End Sub

 (ぶらっと)

 (ぶらっと)さん、忙しいのにたびたびすいません。m(__)m 
 忘れていました。(T_T)
 古いPCを使っているのでバージョンがかなり前のですが、できるのでしょうか？
 エクセルのバージョン：Excel2003
 OSのバージョン：Windows2000

 また間違っていました。かさねて申し訳ございません。m(__)m

 Set myO = Intersect(Target, Range("B3:E8"))  ←  Range("B3:F8")
 オブジェクトが必要です。(Error 424)

 B3＝A15：E22　、　C3＝G15：K22 　、　D3＝M15：Q22　、　E3＝S15：W22  、　F3＝Y15：AC22
 B4＝A26：E33　、　C4＝G26：K33　 、  D4＝M26：Q33　、　E4＝S26：W33  、　F4＝Y26：AC33
 B5＝A37：E44　、　C5＝G37：K44　 、  D5＝M37：Q44　、　E5＝S37：W44  、　F5＝Y37：AC44
 B6＝A48：E55　、　C6＝G48：K55　 、  D6＝M48：Q55　、　E6＝S48：W55　、　F6＝Y48：AC55
 B7＝A59：E66　、　C7＝G59：K66　 、  D7＝M59：Q66　、　E7＝S59：W66　、　F7＝Y48：AC66
 B8＝A70：E78　、　C8＝G70：K78　 、  D8＝M70：Q78　、　E8＝S70：W78　、　F8＝Y48：AC78

 お手数をお掛けいたしますが、よろしくお願いします。（コンドウ）m(__)m

 B3:E8 -> B3:F8 そうだったね。

 >Target　コンパイルエラー　「ByRef 引数の型が一致しません。」と表示します。
 >オブジェクトが必要です。(Error 424)

 この２つの報告から思いついたこと。
提示したコードは、｢提示したコード｣のまま、 Private Sub Worksheet_Change(ByVal Target As Range)
も、そのままで｢シートモジュール｣に貼り付けてくれている？

 シートモジュールは、このシートのシートタブを右クリックして、コードの表示を選んだところ。
こうすることで、シートのB3:F8の領域のどこかに数字を入れると自動実行される。

標準モジュールに張り付けて、それをマクロ実行していない？

 もし、マクロ実行（ボタンでの起動含んで）して、B3:F8にある数字から一括して画像を削除（空白時）、挿入（フォルダに存在時）するということなら
標準モジュール用に、コードを少し手直ししてアップするよ。

 あぁ、そうそう。報告から推察するに、モジュールの先頭に Option Explicit の記述がないのかな？
なくてもOKなんだけど、必須というぐらいの気持ちで必ず記述することを推奨。
（コードで使用する変数の記述を必須にする）

 (ぶらっと)

 (ぶらっと)さん、忙しい間に教えていただき、ありがとうございます。
Cドライブのデータが重たすぎるので、イラストをDドライブのイラストのフォルダに移したのですが、
myPath = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\イラスト\"
をどのように変更したらいいのか教えてください。
お手数をお掛けいたしますが、よろしくお願いします。（コンドウ）m(__)m

 Dドライブ直下であれば
myPath = "d:\イラスト\"

 (ぶらっと)

 (ぶらっと)さん、忙しい間に教えていただき、ありがとうございます。
 B3に007を入力したら「7紐ついた画像ファイルがありません」と表示します。
 Dドライブのイラストフォルダには「007 机」がちゃんとあるのですが？
 お手数をお掛けいたしますが、よろしくお願いします。（コンドウ）m(__)m

 B3:E8 は【数値】ではなく文字列としての【数字】なのかな？
アップしたコードは、B3:E8が【数値】という前提で、たとえば　7 と入れると　007 机　とマッチするようにしてある。

 もし、文字列　007 なのであれば、ちょっとコードを変えて、後ほどアップするね。

 (ぶらっと)

 ↑　と、いったんレスしたけど、文字列形式で　007 と入力しても 007 机　とマッチする。
（当方の xl2003 環境で確認済み）

 マッチしないとすれば
・フォルダ名が違っているか
・アップしたコードは　007 机.jpeg と想定しているけど、実際は 007 机.jpg ？

 後者かな？　実際のファイル拡張子は？　もし拡張子が jpg なら
fName = Dir(myPath & "*.jpeg")　--> fName = Dir(myPath & "*.jpg")
こうして試してみて。

 (ぶらっと)

 (ぶらっと)さん、忙しい間に教えていただき、ありがとうございます。
 「007 机」はjpegですし、 B3:F8 は【数値】ですが、「7紐ついた画像ファイルがありません」と表示します。
 「D:\イラスト」にあるイラストの大きさサイズは関係があるのでしょうか？

 Set myO = Intersect(Target, Range("B3:F8"))
 If myO Is Nothing Then Exit Sub
 myPath = "D:\イラスト"

 お手数をお掛けいたしますが、よろしくお願いします。（コンドウ）m(__)m

 myPath = "D:\イラスト" このように書いたの？

 回答したのは　myPath = "d:\イラスト\"　だけど？

 (ぶらっと)

 (ぶらっと)さん、忙しい間に教えていただき、ありがとうございます。
 思っているようにできました。
 涙(T_T)が出るくらい嬉しくてたまりません。
 ありがとうございました。(^.^)

 今後、挿入位置やイラストの大きさが変更になる場合もありますので、
 忙しいのに申し訳ございませんが、
 ①イラストの「 挿入位置 ( A15 → B13 )」や
 ②イラストの「 大きさ ( A15：E22 → B13:G22 )」を変えたい場合は、
 どこのコードを変更したら良いのか教えてください。
 お手数をお掛けいたしますが、よろしくお願いします。（コンドウ）m(__)m

 場所、大きさについては、いずれも
Set myR = Cells((c.Row - 3) * 11 + 15, (c.Column - 2) * 6 + 1).Resize(8, 5)
ここで規定している。

 まず、数値を入れるセル(c)と画像を貼り付ける領域の左上隅のセルの相関関係を以下の式で求めている。
左上隅のセルの行：(cの行番号-3)*11+15
左上隅のセルの列：(cの列番号-2)*6+1
これはＶＢＡというより算数の問題で、両者の相関ルールを、その時々で見つけ出して計算式で表す必要があるねぇ。

 貼り付け先のサイズは、わかりやすい。
.Resize(8, 5)
８行、５列　ということ。

 (ぶらっと)

 (ぶらっと)さん、忙しい間に教えていただき、ありがとうございます。
 相関関係、難しいですね。
 手探りでやってみます。
 ありがとうございました。感謝（コンドウ）(^.^)

コメント返信：

[ 一覧(最新更新順) ]

[[20120211132623]] 『指定した数字を入力するとイラストが挿入される方』（コンドウ） ページの最後に飛ぶ

[[20120211132623]]　『指定した数字を入力するとイラストが挿入される方』（コンドウ）　ページの最後に飛ぶ