[[20150825180752]]　『マクロの修正について』（666）　ページの最後に飛ぶ

『マクロの修正について』（666）

Ａ１セルに数字を入力すると、画像ファイルが表示されるマクロをネットを参考に
してみましたが、Ａ１　の入力規則のリスト表示が消えてしまいます。入力規則
自体は残っているので、このマクロのせいかと思いますが、私の力ではどうする
ことも出来ませんでした。また、Ａ１セルを消しても、前の画像が残ってしまい
ます。以上２点の修正の仕方を教えてください。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim mypic As Shape
Dim fpath As String, fname As String
Dim i As Long

If Target.Address = "$A$1" And IsNumeric(Target) = True And Target.Value = 0 Then

 MsgBox "数字を入れて下さい。"

ElseIf Target.Address = "$A$1" And IsNumeric(Target) = True And Target.Value <> 0 Then

Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each mypic In ActiveSheet.Shapes

mypic.Delete

i = -6

fpath = ThisWorkbook.Path & "\写真台帳\"
fname = Dir(fpath & Target.Value & "*.jpg", vbNormal)

Do Until fname = ""
i = i + 7

With Range("C" & i)

Set objShape = ActiveSheet.Shapes.AddPicture(Filename:=fpath & fname, _
LinkToFile:=False, SaveWithDocument:=True, Left:=.Left, Top:=.Top, Width:=240, Height:=160)

End With

fname = Dir()

Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End If
End Sub

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 再現しました。不思議ですねぇ。

http://tegetege.air-nifty.com/blog/2011/12/post-4831.html

 原因はわかりませんが、保存しなおすと▼が表示されます。
 （でも、また処理を行えば消えます）

 回答にはなっていませんが情報提供として。

（β） 2015/08/25(火) 19:24

 コードを読んでわかりましたよ。

 For Each mypic In ActiveSheet.Shapes

   mypic.Delete

 Next

 入力規則の▼もシェープです。ですから、それも削除されますから、表示されなくなるわけです。

 ActiveSheet.Pictures.Delete

 これにかえて試してみてください。

（β） 2015/08/25(火) 19:31

 横から失礼します。

 コメントもシェイプです。

 コメントを示す赤い三角は残りますが、コメント自体は削除されます。
（カリーニン） 2015/08/25(火) 20:32

 こういう記述がありました。

 徒然なるままに MS Excel（たまにOffice）
 シェイプを削除

http://d.hatena.ne.jp/belie_kondo/20070220/1207584779

 >コメントが Macro1 で消された場合、そのコメントがあったセルにマウスカーソルを持っていくと、、、
 >Excel が落ちるというおまけがもれなく付いてきます。
 >このおまけがなくなるのは、Excel2007 からです。
（カリーニン） 2015/08/25(火) 20:37

 ▼についてはコメントした通りなんですが、コードに関して。

 １．まず、９０％は問題が出ないと思いますがA1を含んで複数セルに変更があった時に。このコードでは実行時エラーになります。

 　・条件式は、途中で True になろうが False になろうが、最後まで判定実行されます。
 　　そうすると　If Target.Address = "$A$1" And IsNumeric(Target) = True And Target.Value = 0 Then 
 　　この Target.Value = 0 という部分、Targetが複数セルなので、ここでエラーになります。
 　　（たとえば A1 を含み、複数セルを選択して Deleteキーが押されたようなケース）

 ２．さらに↑のとおり、最後まで判定します。なので、And連結で、ずらずら書くより、１つずつの判定で If のネストをしたほうが処理効率はよくなります。
 　　（False になっているのに、おかまいなしに、最後まで判定するのはもったいないですよね）

 ３．If 文の構成そのものもちょっと煩雑な感があります。

 ４．i = -6 にしておいて i = i+7 。気持ちはわかりますが、ここも、素直ではない印象です。

 ５．Application.DisplayAlerts = False/True の必要性がわかりません。

 ６．変数はすべて定義しましょう。

 たとえばの例です。

 Private Sub Worksheet_Change(ByVal Target As Range)

    Dim fpath As String, fname As String
    Dim i As Long
    Dim objshape As Object

    If Target.Address <> "$A$1" Then Exit Sub
    If Not IsNumeric(Target) Then Exit Sub

    If Target.Value = 0 Then

        MsgBox "数字を入れて下さい。"

    Else

        Application.ScreenUpdating = False

        ActiveSheet.Pictures.Delete

        i = 1

        fpath = ThisWorkbook.Path & "\写真台帳\"
        fname = Dir(fpath & Target.Value & "*.jpg")

        Do Until fname = ""

            With Range("C" & i)

                Set objshape = ActiveSheet.Shapes.AddPicture(Filename:=fpath & fname, _
                    LinkToFile:=False, SaveWithDocument:=True, Left:=.Left, Top:=.Top, Width:=240, Height:=160)

            End With

            fname = Dir()
            i = i + 7

        Loop

        Application.ScreenUpdating = True

    End If

 End Sub

（β） 2015/08/25(火) 22:17

皆さん　ご指導頂きありがとうございました。マクロを作ることは好きなので、時々、業務で作業効率を上げようと思っていますが、なかなか、うまくいきません。今回も2週間程度かけて動きを検証してました。とても感謝しています。
（666） 2015/08/26(水) 08:35

コメント返信：

[ 一覧(最新更新順) ]

[[20150825180752]] 『マクロの修正について』（666） ページの最後に飛ぶ

[[20150825180752]]　『マクロの修正について』（666）　ページの最後に飛ぶ