• ベストアンサー

エクセルVBAで画像を貼り付ける座標設定方法は?

Sheets("Sheet1")に貼り付けたJ-pegの画像(=シンボルマーク)を別なシートに貼り付けるのは下記のVBAで出来ました。ただ、これでは貼り付け先のシートのセルK12が、貼り付け元のK12と同じ位置でないと思った場所に張り付きません。 そこでセルで場所を指定するのではなく、座標のようなもので指定する方法はないものかと考えた次第です。 オートシェイプなどは座標指定で作成できるのですが、J-pegのような画像はどうすればいいのでしょうか? Sub TEST() Sheets("FACE").Shapes("シンボルマーク").Copy ActiveSheet.Range("K12").Select ActiveSheet.Paste End Sub

質問者が選んだベストアンサー

  • ベストアンサー
noname#29107
noname#29107
回答No.4

#1です。 >この場合、ファイルをエクセルにくっつけて渡すなんてこと >はできないものでしょうか?(別々にではなくあくまでエク >セルのブックに付属した形で) Excelのブックに付属した形にするなら、コピーペーストする方がいいと思います。一旦挿入した画像を別途保存するのは、簡単には出来ないと思います。 複数のシートで同じような作業をするなら、次のような方法も考えられます。 Function CpyMrk(MrkNM As String, myTop As Single, myLeft As Single) Sheets("FACE").Shapes(MrkNM).Copy ActiveSheet.Paste ActiveSheet.Shapes(MrkNM).Top = myTop ActiveSheet.Shapes(MrkNM).Left = myLeft End Function Sub test() CpyMrk "シンボルマーク", 10, 10 End Sub

AQUALINE
質問者

お礼

何度もお手数をかけ、ありがとうございました。 とても勉強になりました。

その他の回答 (3)

noname#29107
noname#29107
回答No.3

#1です。お礼の中でのご質問の件ですが、 >それともオートシェープのように一行で座標指定する書き方 >もあるのでしょうか? ペーストでは、直接座標を指定できないと思います。 AddPictureメソッドを使ったらどうでしょうか? ActiveSheet.Shapes.AddPicture "フルパスファイル名" _ , msoFalse, msoTrue, 100, 200, 100, 100

AQUALINE
質問者

お礼

AddPictureメソッドという手もあるんですね。 この場合、ファイルをエクセルにくっつけて渡すなんてことはできないものでしょうか?(別々にではなくあくまでエクセルのブックに付属した形で)

  • imogasi
  • ベストアンサー率27% (4737/17068)
回答No.2

>それともオートシェープのように一行で座標指定する書き方もあるのでしょうか? ないと思います。 本題から少し離れ、関連して (数値指定するとき) もし垂直に5つ並べるなら、コピーでなく、いっそのことAddメソッドを繰り返して Sub TEST01() Dim myTop As Single, myLeft As Single For i = 1 To 5 mleft = 100 mtop = (i - 1) * 100 + 50 ActiveSheet.Shapes.AddShape(msoShapeSun, mleft, mtop, 50#, 50#).Select Next i End Sub 水平に並べるならmleftを mleft = (i - 1) * 100 + 50 mtop = 100 にしてはどうでしょう。 (カーソル位置指定) 1個1個指定しては、実行となりますが #1のコードを実行すると、どうも アクチブセルの置き所と貼りつけられたシェイプの位置は 相関関係がありそうですが、良く判りません。初めにコピーする時のアクチブセルの置き所とシェイプとの位置関係を引きずるようでもありますが、自信なし。 セルの位置と関連ずけるなら、 For i = 1 To 5 mleft = Cells(i, 1).Left mtop = Cells(i, 1).Top ActiveSheet.Shapes.AddShape(msoShapeSun, mleft, mtop, 50#, 50#).Select Next i なども可能です。 またTopLeftCellと言うプロパティがあるようですが、値の取得のみで、設定はさせてくれません。 ご参考までに。ご質問と ピントがずれていた場合はご免。

AQUALINE
質問者

お礼

ありがとうございました。 なあるほど・・・・・。 とても勉強になりました。

noname#29107
noname#29107
回答No.1

COPY,PASTEでやるなら、一旦元の座業位置を保存し、ペースト後のshapeに適用するのが普通かと思います。 Sub TEST() Dim myTop As Single, myLeft As Single myTop = Sheets("FACE").Shapes("シンボルマーク").Top myLeft = Sheets("FACE").Shapes("シンボルマーク").Left Sheets("FACE").Shapes("シンボルマーク").Copy ActiveSheet.Paste ActiveSheet.Shapes("シンボルマーク").Top = myTop ActiveSheet.Shapes("シンボルマーク").Left = myLeft End Sub

AQUALINE
質問者

お礼

さっそくありがとうございました。これならオリジナルと寸分違わない位置に配置できますね。勉強になりました。 ところで、オートシェープだと ActiveSheet.Shapes.AddShape(msoShapeSun, 509.25, 47.25, 141#, 138#).Select のように、直接、座標を入れられますが、Copyで持ってくるものは、この場合、myTopやmyLeftに代入するしか方法はないですか? それともオートシェープのように一行で座標指定する書き方もあるのでしょうか?

関連するQ&A

  • VBA 印刷範囲設定がうまくいかない

    変数cntに値を代入し印刷範囲が変わるという事を、以下のコードで実行しようとしています。 Sub Macro1() cnt = 9 Sheets("A").Activate 範囲 = Sheets("A").Range(Cells(1, 1), Cells(33, cnt + 1)) ActiveSheet.PageSetup.PrintArea = 範囲 上記のコードですと、シート「A」のセルA1~J33までが印刷範囲になると思ったのですが、実行すると全く関係ないセルまで印刷範囲になってしまいます。 「A」シートには罫線やデータが入力されているセルが他にもあり、どうやらそれらのセルも同じく印刷範囲とされてしまっているようなのです。(例えばK列に罫線が引いてあり、セルに色がついているとK列まで印刷範囲になる) Sheets("A").Range(Cells(1, 1), Cells(33, cnt + 1)).select とすれば、望みどおりのセル範囲A1~J33がきちんと選択されるのですが、印刷範囲ではなぜこのようなことになってしまうのでしょうか。

  • エクセルVBAでシートコピー

    Sheets("Sheet1")をCopyして、現在の最終のシートの後に持っていき、それを変数wsに設定しようとしています。 Sub TEST01() Sheets("Sheet1").Copy After:=Sheets(Sheets.Count) Set ws = Sheets(Sheets.Count) MsgBox ws.Name End Sub これで通常はうまくいきますが、最終シートが非表示になっているとwsはその非表示のシートが指定され、Sheets("Sheet1")をCopyしたものでなくなってしまいます。 Sheets("Sheet1")をCopyして、現在の最初のシートの前に持っていき、それを変数に設定しようとしています。 Sub TEST02() Sheets("Sheet1").Copy Before:=Sheets(1) Set ws = Sheets(1) MsgBox ws.Name End Sub これで通常はうまくいきますが、最初のシートが非表示になっているとwsはその非表示のシートが指定され、Sheets("Sheet1")をCopyしたものでなくなってしまいます。 Set ws = ActiveSheet で設定できましたが、それ以外の方法はないでしょうか?

  • エクセル VBA

    (1) Sub 印刷() With Sheets("原本") .Cells.FormatConditions.Delete .PageSetup.PrintArea = Range("A1:K73").Address .PrintOut End With End Sub としているのですが ボタンを間違って押した時も印刷がされてしまいます 押したときに 印刷しますか? はい いいえ みたいなのを確認するようにしたいのですが どうすればいいでしょうか? (2) Sub 保存() Dim MySheetName As String MySheetName = InputBox("シート名を入力してください") Sheets("9月1日").Copy After:=Sheets(Worksheets.Count) ActiveSheet.Name = MySheetName Sheets("原本").Range("A1:K73").Copy Sheets("原本").Range("A1") End Sub で原本シートをコピーして新しいシートを作成するプログラムを 作ったのですが、シート名を入力しはいを押すと作成されるのですが キャンセルを押した時も勝手にシートが作成されるのですが キャンセル時は何もシートを作成しないように したいのですが どうしたらいいでしょうか? どちらも教えて貰いながら作成したため 自分で修正できなく困ってます お手数ですがよろしくお願いします

  • VB6 エクセルに画像貼り付け

    お世話になります。 VB6でエクセルのセルを数値で指定して、そこに画像を読み込んで実態を張り付けたいのですが、 色々調べて ActiveSheet.Pictures.Insertと ActiveSheet.Shapes.AddPictureを試してみましたが ActiveSheet.Shapes.AddPicture( FileNameTmp, False, True, 10, 20, 0, 0) AddPictureはもしかしてVB6には対応していないのでしょうか? 構文エラーになってしまいます。 ActiveSheet.Pictures.Insert(FileNameTmp).Select Insertだと画像がリンクになってしまいます。

  • Excel VBA で自在に図形を変化させたい

    Excel VBAを使って図形を自由に変化させたいと思っています。 一つの形の四角形や三角形をVBAを使ってシート上に表記することは出来ます。 私はユーザーインターフェースを作り、テキストボックスに値を入れることで図形を変化させることをしたいと思っています。 例えば、一つの三角形を正三角形にしたり、直角二等辺三角形にしたり、自在に角度を変えてVBAに描かせたいと思っています。 三角形は以下のようにコードを記述しましたらシートに表示できました。 Sub 三角形作成() Set ArwLine = ActiveSheet.Shapes.AddLine(10, 10, 200, 200) Set ArwLine = ActiveSheet.Shapes.AddLine(200, 200, 100, 400) Set ArwLine = ActiveSheet.Shapes.AddLine(100, 400, 10, 10) End Sub これを以下のようにして変数(x、y)にユーザーインターファースから値を代入するようにしたいのですがどのようにすればよいのでしょうか教えてください。 Private Sub CommandButton1_Click() UserForm1.Show End Sub Sub 三角形作成() Set ArwLine = ActiveSheet.Shapes.AddLine(10, 10, 200, 200) Set ArwLine = ActiveSheet.Shapes.AddLine(200, 200, x, y) Set ArwLine = ActiveSheet.Shapes.AddLine(x, y, 10, 10) End Sub 前回、「Excel VBAで図面を書きたい」という質問をしたのですがややこしく書いたため解答される方が居ませんでしたので編集して再質問をさせていただきます。 よろしくお願いします。

  • Excel エクセル マクロ VBA

    エクセルマクロで指定したシート(2シート目)から末尾のシートまで印刷したい場合、下記のようなコードで良いでしょうか? Sub Sample1() Dim i As Long For i = 2 To Sheets.Count ActiveWorkbook.Sheets(i).Select (Replace:= False) Next i Activesheet.PrintOut Preview:=True End Sub

  • エクセルVBAで

    いつもお世話になります。 Sub ボタン_Click() Sheets("別紙1").Range("E1") = ActiveSheet.Name Sheets("別紙1").Activate Range("B65536").End(xlUp).Offset(1).Select End Sub Sub ボタン1_Click() i = Range("B65536").End(xlUp).Offset(, -1).Value na = Range("E1") Sheets(na).Activate ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", _ SubAddress:="別紙1!B" & i + 2, TextToDisplay:=Str(i) End Sub 上記モジュールで、ボタンをクリックすると別紙1に飛んで、その中に必要事項を記入後、ボタン1をクリックすると、ボタンをクリックしたときにアクティブだったセルに、ハイパーリンクを貼るものを利用していました。 先日、これらモジュールが貼られているシートを保護をかけて再度保護を解除したら、今までボタンを押したときにアクティブだったセルにハイパーリンクが貼れていたのに、A1のセルに記入してしまうようになりました。 そこで、不具合を改善すべく、上記モジュールを書き換えて、ボタンをクリック時にアクティブセルを別紙1のE2の保存しておいて、ボタン1をクリックするとそのE2のセルに戻ってハイパーリンクを貼るというものにしなおしたいと思います。 そこで質問ですが、ボタンをクリックした時点で、アクティブであるセルの座標(表現の方法が不適切かもしれませんが)を取得するにはどのようにすればいいでしょうか? ちなみに、E1にはクリックした時点でアクティブであるシート名を記録し、ボタン1をクリックしたときにそのシートへ戻るようにしてあります。 以上、ご教示の程よろしくお願いします。

  • Excel VBAで、検索後行の挿入をしたい。

    A B C  1月 金額 2月 金額 3月 金額 1 5 100 15 300 ・・ 2 3 60 15 300 ・・ という表があります。 この表(シート1)を、別のシート(シート2)にコピーして、 「金額」行の隣に1行追加したいのです。。。 Sub 貼付け() Sheets("シート1").Select Cells.Select   Selection.Copy   Sheets("シート2").Select   ActiveSheet.Paste End Sub Sub 検索後挿入()   Dim objRange As Range  Set objRange = Columns("2:2").Find("金額") として、金額を探すまではできました。 金額セルの隣を選択し、3行追加するにはどうしたらいいでしょうか・・。どうぞ宜しくお願いします!

  • EXCELのVBAで画像ファイルを呼び出し

    EXCELのVBAでセルに入力されているファイル名の画像ファイルを呼び出して、 トリミング、縮小→一旦切り取り、メタファイルで貼り付け→セルの真ん中に配置ということを行いたいです。 このようなVBAを組みましたが、bw = .Width でエラーが起こってしまいます。 一旦切り取りして貼り付けするコードを加えたらエラーになりました。 どのようにしたらきちんと希望の形ではりつけることができるでしょうか? よろしくお願いします。 Sub photocalltest() 'セルの値を取得して画像を貼り付け ' ' Dim i As Long For i = 2 To 5 ActiveSheet.Pictures.Insert ("C:\Documents and Settings\temp\" & Cells(7, i).Value & ".jpg") With ActiveSheet.Shapes(ActiveSheet.Shapes.Count) 'トリミング .PictureFormat.CropBottom = 95 .PictureFormat.CropRight = 57.78 .PictureFormat.CropLeft = 59.28 .PictureFormat.CropTop = 100 '縮小 .Height = 197.25 .Width = 162# .Cut 'Cells(7, i).Select ActiveSheet.PasteSpecial Format:="図 (拡張メタファイル)" '貼り付け位置指定 aw = Cells(7, i).Width bw = .Width //ここでオブジェクトが必要ですエラー x = (aw - bw) / 2 .Left = Cells(7, i).Left + x ah = Cells(7, i).Height bh = .Height y = (ah - bh) / 2 .Top = Cells(7, i).Top + y End With Next i End Sub

  • エクセルVBAでオートシェイプを点滅させたい。

    エクセル2000です。 ワークシートに配置したオートシェープ(「矢印」と名前を付けてあります。)をチカチカさせたいのです。 Sub マーク点滅() Dim i As Integer i = 0 Do i = i + 1 Loop Until i = 3 Sheets("AAAA").Shapes("矢印").Visible = True Sheets("AAAA").Shapes("矢印").Visible = False End Sub とやってみましたがぜんぜんだめでした。 いい方法はないでしょうか?

専門家に質問してみよう