エクセル 画像挿入マクロで、ずれます

　エクセル2003　・　挿入ファイルは　ｅｍｆ　です。

　毎回　かなりの頻度で　挿入→微調整（幅をかえたり位置をかえたり）の作業があり、非常に効率が悪くマクロで出来ないものかと思いトライしていますが、何故か実行すると、少しずれて挿入（もしかすると挿入後の調整部がずれている？）されてしまいます。

後、下記のようなエラーがでる時があります。

実行時エラー’-2147024809（80070057）’：
指定した名前のアイテムが見つかりませんでした。

マクロくんですぐなので、ファイルを消してもいません。　
エラーがでたマクロでは毎回同じ場所でエラーになります。何が原因なのでしょうか？

　マクロで、ずれない様に挿入・位置・幅調整はどのようにするのでしょうか？　（マクロ編集で数値をかえて調整しようかとおもいましたがいまいち微調整がうまくできません）

No.3 ベストアンサー 回答者： xls88 回答日時： 2009/07/12 01:06

良く分かりませんが、第一引数の

msoFalse を msoTrue にすればどうなるでしょうか？

Selection.ShapeRange.ScaleHeight 0.43, msoTrue, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.48, msoTrue, msoScaleFromTopLeft

下記マクロも試してください。
補正値は調整（加減、大小）してください。

Sub test2()
Dim pic As Picture
Dim pth As String
Dim pname As Variant
Dim rng As Range
Dim i As Integer

pth = "C:\Users\note\Desktop\テスト材料\jpg変換済み\材料\"
pname = Array("2-小", "2-大")
Set rng = Range("B24:N54, O9:X54") '挿入開始セル範囲
For i = 0 To UBound(pname)
Set pic = ActiveSheet.Pictures.Insert(pth & pname(i) & ".emf")
With pic
.Left = rng.Areas(i + 1).Left - 0.75
.Top = rng.Areas(i + 1).Top - 0.75
.ShapeRange.LockAspectRatio = msoFalse '縦横比を無視
.Height = rng.Areas(i + 1).Height + 1.5
.Width = rng.Areas(i + 1).Width + 1.5
End With
Next i
End Sub

この回答へのお礼

　ありがとうございます。
＞msoFalse を msoTrue
は同結果でした。

　再度教えていただいたマクロでＯＫでした。とても時間短縮でき大感激です。本当にありがとうございました。

お礼日時：2009/07/12 23:23

No.2 回答者： xls88 回答日時： 2009/07/11 04:32

＞回答番号：No.1 この回答への補足

質問1）
ActiveSheet.Pictures.Insert("C:\Users\note\Desktop\テスト材料\jpg変換済み\材料\2-小.emf").Select
With Selection
.Left = Range("B24").Left
.Top = Range("B24").Top
End With
Selection.ShapeRange.IncrementLeft 0.75
Selection.ShapeRange.IncrementTop 0.75
Selection.ShapeRange.ScaleHeight 0.43, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft

ActiveSheet.Pictures.Insert("C:\Users\note\Desktop\テスト材料\jpg変換済み\材料\2-大.emf").Select
With Selection
.Left = Range("O9").Left
.Top = Range("O9").Top
End With
Selection.ShapeRange.IncrementLeft 0.75
Selection.ShapeRange.IncrementTop 0.75
Selection.ShapeRange.ScaleHeight 0.43, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft

質問2）
次のシートをActiveにする
Sheet("Sheet2").Activate

質問３）
下記コードで数値を変えてみる
Selection.ShapeRange.IncrementLeft 0.75
Selection.ShapeRange.IncrementTop 0.75
Selection.ShapeRange.ScaleHeight 0.43, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft

下記マクロを試してみてください。
詳細がよく分からないので挿入位置とか適当に決めています。
Sub test1()
Dim pic As Picture
Dim pth As String
Dim pname As Variant
Dim rng As Range
Dim i As Integer

pth = "C:\Users\note\Desktop\テスト材料\jpg変換済み\材料\"
pname = Array("2-小", "2-大")
Set rng = Range("B2:H12") '挿入開始セル範囲
For i = 0 To UBound(pname)
Set pic = ActiveSheet.Pictures.Insert(pth & pname(i) & ".emf")
With pic
.Left = rng.Left
.Top = rng.Top
.ShapeRange.LockAspectRatio = msoTrue '縦横比維持
.Height = rng.Height '高さ基準
'.Width = rng.Width '幅基準
End With
Set rng = rng.Offset(12) '挿入位置を12行下方にずらす
Next i
End Sub

この回答へのお礼

　度々ありがとうございます。　
質問1・2（２つの画像挿入と次のシートへ移動）は理解できました。
どうしても質問3の幅調整がうまくいきません（位置調整はうまくいきそうです）
＞Selection.ShapeRange.ScaleHeight 0.43, msoFalse, caleFromTopLeft
の値を0.434にすると足らず（狙いより６ピクセル程小さい）、 0.435にすると一気に伸びます（狙いより６ピクセル程大きい）。0.001倍の差で何故ここまで違うのかわかりません。
　横のほうも 0.475と0.476で同じような感じです。自分なりにずっと調べているのですが理解力が乏しいのか解決できません。

＞下記マクロを試してみてください。
位置はファイル2-小　をB24:N54へ　
2-大をO9:X54に挿入したいので
Set rng = Range("B24:N54", "O9:X54")としたのですが駄目でした。
取りあえず単体でどうなるかと思い、2-小を
Set rng = Range("B24:N54"）としてみましたが、指定どおりきました。しかし、僅かに左と上によっている感じです（カーソールを右と下を一回ずつ押し右と下の幅を狭めればよい感じでした・・・セルの枠線が太いのですが半分消えてる感じです）

　画像にラインが数本あり、セルの枠線と合わせないといけない為、微調整が必要となります。（一度うまくいけば、ライン位置などはすべて同じですので大丈夫です）その為、質問1で回答頂いたマクロの方がうまくできるのであれば微調整しやすいかもしれません・・・ど素人の発想ですが。

　　あと少しで解決できそうです。お力をお貸しください。

お礼日時：2009/07/11 23:19

No.1 回答者： xls88 回答日時： 2009/07/10 00:34

セルを指定すればどうでしょうか。

Dim pic As String

pic = "C:\Users\○○○\Pictures\AAA.jpg"
With ActiveSheet.Pictures.Insert(pic).ShapeRange
　　.Left = Range("B2").Left
　　.Top = Range("B2").Top
End With

一度、現状のマクロを提示していただくことはできないでしょうか。

この回答への補足

　マクロをくんで・・と質問しましたが表現が間違っていました。
組むほどの知識はありません。記録のスタートで作成しているレベルです。もっと勉強します。とりあえず回答いただいた物を挿入し指定の場所に挿入ができました。

ただ、
質問1）
同シートにもう１つの画像を挿入するときには同すればよいのか？（連続で回答していただいた物を貼り付けましたがエラーになります）

質問2）
次のシートに挿入するにはどうすればよいのか？

質問３）
挿入した画像の位置（右に1、下に1つずらす・・カーソールの→や下を１回押す・）や縦横の幅調整はどのようにすればよいのか？

取り急ぎこの３つが理解できればどうにかなりそうです。
こちらも勉強をしてみますが何分急いでいますので教えていただけたら助かります。

補足日時：2009/07/10 11:01

この回答へのお礼

　ありがとうございます。　２つのシート各2つの画像を挿入しましたが、1つ目のシートの２つ目で　”指定した名前のアイテムが見つかりませんでした”と表示されそれ以降挿入されません。
下記がマクロです。よろしくおねがいします。仕事がはかどらず困っています。（文字制限があるので後半削除します）
Sub Macro2()
' Macro2 Macro
' マクロ記録日 : 2009/7/10 ユーザー名 : note
' Keyboard Shortcut: Ctrl+Shift+A
Range("B24").Select
ActiveSheet.Pictures.Insert("C:\Users\note\Desktop\テスト材料\jpg変換済み\材料\2-小.emf"). _
Select
ActiveWindow.SmallScroll Down:=75
Selection.ShapeRange.IncrementTop 0.75
Selection.ShapeRange.ScaleHeight 0.43, msoFalse, msoScaleFromTopLeft
ActiveWindow.SmallScroll Down:=-18
Selection.ShapeRange.ScaleWidth 0.48, msoFalse, msoScaleFromTopLeft
ActiveWindow.SmallScroll Down:=-18
Range("P33").Select
ActiveSheet.Shapes("Picture 201").Select
Selection.ShapeRange.IncrementLeft 0.75
ActiveWindow.SmallScroll Down:=6
Range("O41").Select
ActiveWindow.SmallScroll Down:=-18
Range("O9").Select
ActiveSheet.Pictures.Insert("C:\Users\note\Desktop\テスト材料\jpg変換済み\材料\2-大.emf"). _
Select
ActiveWindow.SmallScroll Down:=96
Selection.ShapeRange.IncrementTop 0.75
ActiveWindow.LargeScroll ToRight:=1
Selection.ShapeRange.IncrementLeft 0.75
ActiveWindow.SmallScroll Down:=-42
Selection.ShapeRange.ScaleWidth 0.43, msoFalse, msoScaleFromTopLeft

お礼日時：2009/07/10 10:39