　エクセルに写真を挿入するマクロを組んでいます。

Question

エクセルに写真を挿入するマクロを組んでいます。
２００３までは問題なく動作していたマクロが、
２００７では位置調整がうまく行きません。
　そこでネットで検索して
With Selection
        .Left = Range("C6").Left
        .Top = Range("C" & rowa).Top
End With
のように　Selection.Left　を使えば解決するとありましたが、

(1)ＷＩＮ　ＶＩＳＴＡのエクセル２００７では
おなじひとつのエクセルファイルの
あるシートではコード通りが位置でるのに
違うシートでは縦位置がずれる。

(2)ＷＩＮ　ＸＰのエクセル２００７では
すべてのシートで縦位置がずれる。
ただし、ずれの位置は(1)よりは少ない。

といずれのＯＳでも不具合が出ます。

事情によりエクセル２００７でこのマクロを使用しなければならなくなり
非常に困っております。
どなたか解決方法をご存知の方、よろしくお願いします。

なお、(2)のＷＩＮ　ＸＰでは、エクセル２００３も入っており、
その中では、全く問題なくマクロが動作しています。
実際のコードは下の通りです。

Sub 写真呼出(koumoku, jpgf, tr As Variant)
    Dim rowa As String
    
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = tr　←選択したセルの行ナンバー
    
    ActiveSheet.Pictures.Insert(motopath & "写真\" & koumoku & "\" & jpgf & ".JPG").Select
    Selection.Name = "写真"
    
    Selection.ShapeRange.LockAspectRatio = msoTrue '縦横比の固定
    Selection.ShapeRange.Height = 480

'Selection.ShapeRange.IncrementLeft 100　←不具合が出たので止めた部分
    'Selection.ShapeRange.IncrementTop 40　　←不具合が出たので止めた部分
   
    rowa = tr + 2
    
    With Selection
        .Left = Range("C6").Left
        .Top = Range("C" & rowa).Top
    End With

End Sub

end-u · Accepted Answer

2007はPictures.Insertメソッドで位置がズレるという話があったような気がしますね。
私のwinXPsp3/xl2007sp2(12.0.6535.5002)環境で試してみましたが、
どうも再現しません。
OfficeUpdateはお済みでしょうか。
#必要なら後日Vistaでも試してみますが。

とりあえず
【お試し案１】Selectしない
Dim rowa　As String
Dim fname As String
rowa = tr + 2
fname = motopath & "写真\" & koumoku & "\" & jpgf & ".JPG"
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = tr
With ActiveSheet.Pictures.Insert(fname)
　　.ShapeRange.LockAspectRatio = msoTrue
　　.Name = "写真"
　　.Height = 480
　　.Left = Range("C" & rowa).Left
　　.Top = Range("C" & rowa).Top
End With

【お試し案２】Zoom変更
Dim rowa　As String
Dim fname As String
Dim n　　 As Long
rowa = tr + 2
fname = motopath & "写真\" & koumoku & "\" & jpgf & ".JPG"
With ActiveWindow
　　n = .Zoom
　　.Zoom = 100
End With
ActiveSheet.Pictures.Insert(fname).Select
With Selection
　　.ShapeRange.LockAspectRatio = msoTrue
　　.Name = "写真"
　　.Height = 480
　　.Left = Range("C" & rowa).Left
　　.Top = Range("C" & rowa).Top
End With
With ActiveWindow
　　.Zoom = n
　　.ScrollColumn = 1
　　.ScrollRow = tr
End With

【お試し案３】Shapes.AddPictureメソッド
Dim rowa　As String
Dim fname As String
rowa = tr + 2
fname = motopath & "写真\" & koumoku & "\" & jpgf & ".JPG"
With ActiveSheet.Shapes.AddPicture(Filename:=fname, _
　　　　　　　　　　　　　　　　　 LinkToFile:=msoFalse, _
　　　　　　　　　　　　　　　　　 SaveWithDocument:=msoTrue, _
　　　　　　　　　　　　　　　　　 Left:=Range("C" & rowa).Left, _
　　　　　　　　　　　　　　　　　 Top:=Range("C" & rowa).Top, _
　　　　　　　　　　　　　　　　　 Width:=100, _
　　　　　　　　　　　　　　　　　 Height:=100)
　　.ScaleHeight 1, msoTrue
　　.ScaleWidth 1, msoTrue
　　.LockAspectRatio = msoTrue
　　.Name = "写真"
　　.Height = 480
End With
With ActiveWindow
　　.ScrollColumn = 1
　　.ScrollRow = tr
End With

end-u · Answer

ぁ、失礼。
>fname = motopath & "@myDoc\" & koumoku & "\" & jpgf & ".JPG"
こりゃ自分の環境でしたorz
fname = motopath & "写真\" & koumoku & "\" & jpgf & ".JPG"
修正してくださいね。

end-u · Answer

Zoomの問題のようですね。
>WIN XP SP3で、エクセル2007SP?（12.0.4518.1014）です。
OfficeUpdateで直りそうな気もしますが、以下で。

Sub 写真呼出(koumoku, jpgf, tr As Variant)
　　Dim rowa　As String
　　Dim fname As String
　　Dim n　　 As Long
　　Dim r　　 As Range

On Error GoTo errHndlr
　　rowa = tr + 2
　　fname = motopath & "@myDoc\" & koumoku & "\" & jpgf & ".JPG"
　　Set r = ActiveCell
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Goto Range("A" & tr), True
　　End With
　　With ActiveWindow
　　　　n = .Zoom
　　　　.Zoom = 100
　　End With
　　With ActiveSheet.Pictures.Insert(fname)
　　　　.ShapeRange.LockAspectRatio = msoTrue
　　　　.ShapeRange.Height = 480
　　　　.Left = Range("C" & rowa).Left
　　　　.Top = Range("C" & rowa).Top
　　　　.Name = "写真"
　　End With
　　ActiveWindow.Zoom = n
　　r.Activate

errHndlr:
　　Set r = Nothing
　　With Application
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
End Sub

>お試し案１，３とも表示位置は正しく出ていましたが
>写真の横サイズが調整されずに元のサイズのまま？長くなっていました。
１，２は、ShapeRangeに対してHeight変更するのを忘れてました。すみません。
３は...再現しなかったのでわかりません。ActiveCell位置も関係ないですしね。
２ならありえますが。
上記コードはその辺りも一応考慮してます。

いずれにしても、Service Packはあてといた方が良いと思いますけども。
http://support.microsoft.com/kb/928116/ja
Microsoft Updateを利用してください。
http://update.microsoft.com/microsoftupdate/v6/default.aspx?

>#必要なら後日Vistaでも試してみますが。
ちなみにVistaでも再現しませんでした。

imogasi · Answer

２００７で検証が出来ないのですが、私は
Top = Range("C" & rowa).Top
のセルについて
質問者が目指すものと
コード実行の現実が違うだけで、
この程度の内容の個所は、バージョンの変更で影響を受けてないと予想します。
テストをじっくりしてみるのが先決ではないですか。
具体的にC6などセルを指定しても「ずれ」が起こりますか？その際セルのシートを明示のこと。
他にシートのセルと貼り付けた図形（オブジェクト）の位置関係をコントロールする、「図の書式設定」の「プロパティ」なども、念のためチェックを。

hige_082 · Answer

＃１です
難しいです
関連するコードが分らないので無理に近いですよ
関連するすべてのコードを見ないと
どのコードが関係しているのかわかりません

＞因みに
＞'Cells(tr, 3).Select
＞でこのコードを無効化すると何故か・・・
原因が特定できません
良い方法では有りませんが
Application.EnableEvents = False
Cells(tr, 3).Select
Application.EnableEvents = True
としたらどうなります？

アドバイスとしては
コード中のselection(select)を極力無くしてください
selectionでは何に対して処理をしているのかが分りにくい
スキルが上がってくると最後の表示くらいにしか使用しません

Worksheet_SelectionChangeなどイベントを使用する場合は
範囲を限定して他のコードに影響のないようにする
今回のように"Cells(tr, 3).Select"を実行すると
無限ループにならないよう対策をする必要があると思います

すべてのコードを見直す必要があると思いますよ

hige_082 · Answer

たいした修正はしていませんが、試してみて

Sub 写真呼出(koumoku, jpgf, tr As Variant)
Dim rowa As String
Cells(tr, 3).Select
rowa = tr + 2
ActiveSheet.Pictures.Insert(motopath & "写真\" & koumoku & "\" & jpgf & ".JPG").Select
Selection.Name = "写真"
With ActiveSheet.Pictures("写真")
.LockAspectRatio = msoTrue '縦横比の固定
.Height = 480
.Left = Range("C" & rowa).Left
.Top = Range("C" & rowa).Top
End With
End Sub

excel2007を持っていないので検証できてません

参考程度に

エクセルに写真を挿入するマクロを組んでいます。

2007はPictures.Insertメソッドで位置がズレるという話があったような気がしますね。

この回答への補足

ぁ、失礼。

Zoomの問題のようですね。

２００７で検証が出来ないのですが、私は

この回答への補足

＃１です

この回答への補足

たいした修正はしていませんが、試してみて

この回答への補足

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

　エクセルに写真を挿入するマクロを組んでいます。