- ベストアンサー
VBAでオートシェイプの制御？
mythismの回答
- mythism
- ベストアンサー率52% (45/86)
以下のようにしてみてはいかがでしょうか． Private Sub Worksheet_Change(ByVal Target As Range) If Target <> Range("A1") Then Exit Sub If Target.Value = 1 Then With ActiveSheet.Range("B2") ActiveSheet.Shapes.AddShape(Type:=msoShapeHeart, _ Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height).Select End With Selection.Name = "MyHeart" Else ActiveSheet.Shapes("MyHeart").Delete End If End Sub
関連するQ&A
- エクセルVBA オートシェイプを操作したいです
エクセルでセルの入力内容によって楕円をオートシェイプで出現させたいと思います。 http://oshiete1.goo.ne.jp/qa809742.htmlで見つかったものを参考にし、 Private Sub worksheet_Activate() Dim Shp As Shape Set P11 = Range("P11") If P11 Is Nothing Then Exit Sub If P11.Value = 1 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N14:N15") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left,TOP:=.TOP,Width:=.Width,Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N14").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N14:N15")) Is Nothing Then Shp.Delete End If Next Shp End If If P11.Value = 2 Then For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp With ActiveSheet.Range("N16") ActiveSheet.Shapes.AddShape(Type:=msoShapeOval, _ Left:=.Left, TOP:=.TOP, Width:=.Width, Height:=.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse End With Range("N16").Select Else For Each Shp In ActiveSheet.Shapes If Not Application.Intersect(Shp.TopLeftCell, _ Range("N16")) Is Nothing Then Shp.Delete End If Next Shp End If End Sub とつなげて見ました。 動くには動くのですが、データ元のセルがP11からT30と100セルあり、さらにP11に入力されるデータが１，２，３，４の4種類、AQ11に５，６，７，８，９の5種類などと、ばらばらです。 P11に１が入力されるとN14:N15(結合されています)に円が入り、２が入力されるとN16に円が入る。 Q11に５が入力されるとR13に円が入り、６が入力されるとR14:R15に円が入る・・・・のようにしたいのです。 一生懸命、セルNo.を打ち込んでいたら、 「コンパイルエラー：プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。
- ベストアンサー
- その他MS Office製品
- VBAの写真貼り付けコードについて教えてください。
写真をダブルクリックで簡単に貼り付けられるVBAのプログラムを友人に貰ったのですが、 追加で図の外枠に黒の2.5ptくらいの線を縁取る文を追加しようと、マクロで記録したプログラムを 入れてみたのですが上手く動作しません。 コードが --------------------------------------------------------------------------------- Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Cancel = True If Target.MergeCells = False Then Exit Sub '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then Exit Sub End If '===============画像の掃除 For Each mySP In ActiveSheet.Shapes myAD1 = mySP.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySP.Delete Next '===============画像の貼り付け Set mySP = ActiveSheet.Pictures.Insert(myF) '===============タテヨコの縮尺を保持 myHH = Target.Height / mySP.Height myWW = Target.Width / mySP.Width If myHH > myWW Then mySP.Height = mySP.Height * myWW mySP.Width = Target.Width Else mySP.Height = Target.Height mySP.Width = mySP.Width * myHH End If '===============中央へ調整 myHH2 = (Target.Height / 2) - (mySP.Height / 2) myWW2 = (Target.Width / 2) - (mySP.Width / 2) mySP.Top = Target.Top + myHH2 mySP.Left = Target.Left + myWW2 Set mySP = Nothing End Sub ------------------------------------------------------------------------- お願いいたします。
- 締切済み
- Visual Basic
- 図形消去後に文字入力(エクセル）
Sub test() Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea wTop = .Top wLeft = .Left wBottom = .Top + .Height wRight = .Left + .Width End With For Each s In ActiveSheet.DrawingObjects With s If wTop <= .Top And _ wLeft <= .Left And _ wBottom >= .Top + .Height And _ wRight >= .Left + .Width Then .Delete End If End With Next Next End Sub 上記マクロは、選択状態になっている個々のセルの中に、すっぽり収まる状態で存在しているオブジェクトを消去します。 オブジェクトが消去されたセルに、"○"が入力されるようにしたいのですが。 どういった記述が必要になるでしょうか？
- ベストアンサー
- オフィス系ソフト
- 図形の移動をセンチの数値でマクロを実行したい
エクセル初心者です。 以下のマクロを教えて頂きました。 セルに入力する数値は他の計算式から数値を割り出しています。 このマクロをセンチで入力して、実行する事は可能でしょうか。 その方法がありましたら、教えてください。 Private Sub Worksheet_Change(ByVal Target As Range) With ActiveSheet.Shapes.Range(Array("Group 1")) .Top = 100 .Left = 100 .Height = ActiveSheet.Range("A2").Value .Width = ActiveSheet.Range("A3").Value End With End Sub よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- Excelの写真貼り付け(90度回転)について
xcelに写真のサイズを自動的に変更するマクロ、(セルの大きさに合わせて）を利用しています。 このマクロに対して写真を90度角度を変更して、写真を表示させたいのですが、どのようにすればよいのでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) ActiveSheet.Unprotect Dim C As Range, cm As Range Application.ScreenUpdating = False For Each C In Selection Set cm = C.MergeArea If C.Address = cm.Item(1).Address Then If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub With Selection .Left = cm.Left .Top = cm.Top .Height = cm.Height .Width = cm.Width End With End If Next Set cm = Nothing Application.ScreenUpdating = True Range("a1").Select End Sub
- 締切済み
- その他MS Office製品
- VBAにて写真貼り付け
EXCEL2010を使用しています。 Ｄ3に於いて名前を選択できるようにしています。Ｄ3に入力する名前と同一の写真（JPG)がDISK TOP上フォルダー内に複数あります。 Ｄ3で名前選択時,該当する写真をA5:M29に表示したい。 以下のコードは他の方が使われてるコードを参考にしたもので、※印の場所でエラーとなります何が 原因なのか？他の部分も合わせ教えて下さい。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$D$3" Then myPath = "C:\Users\Users\DeskTop\PHOT" myFile = myPath & Range("D3").Text & ".jpg" For Each sh In ActiveSheet.Shapes If Left(sh.Name, 7) = "Picture" Then sh.Delete End If Next Range("A5:M29").Select myTop = Selection.Top myLeft = Selection.Left myWidth = Selection.Width myHeight = Selection.Height ※ActiveSheet.Pictures.Insert(myFile).Select With Selection .Top = myTop .Left = myLeft .Width = myWidth '画像の幅 .Height = myHeight '画像の高さ End With Range("D3").Select End If End Sub
- ベストアンサー
- Visual Basic
- エクセルに写真を挿入するVBA
エクセルで写真集を作るためのVBAですが、以下のVBAでは画像がリンク貼り付けになってしまいます。どうしたらエクセルファイルに画像を貼りこみで保存できるのでしょうか？ よろしくお願いいたします。 やりたいことは、まずダブルクリックでダイアログボックスを表示させ、挿入したい写真を選択、写真がセルに合わせた大きさに縮小、セルの中央に写真を配置。以上です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) Dim PicFile As Variant Dim rX As Double, rY As Double '［ファイルを開く］ダイアログボックスを表示 PicFile = Application.GetOpenFilename( _ "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp") If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub Application.ScreenUpdating = False '画像を挿入 With ActiveSheet.Pictures.Insert(PicFile) rX = Target.Width / .Width rY = Target.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If 'セルの中央（横方向/縦方向の中央）に配置 .Left = Target.Left + (Target.Width - .Width) / 2 .Top = Target.Top + (Target.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True End Sub
- 締切済み
- その他MS Office製品
- エクセル２００７のVBAの困りごと
教えてください。 画像挿入時にエクセルのセルの大きさに合わせるマクロを使っているのですが、エクセル２０００、２００３では問題なく動くのですが、２００７だと、うまくVBAが動かず、画像が縮小・拡大されません。 わかるかた教えてください。 コード Dim c As Range, cm As Range Application.ScreenUpdating = False For Each c In Selection Set cm = c.MergeArea If c.Address = cm.Item(1).Address Then If Application.Dialogs(xlDialogInsertPicture).Show = False Then Exit Sub With Selection .Left = cm.Left .Top = cm.Top .Height = cm.Height .Width = cm.Width End With End If Next Set cm = Nothing
- 締切済み
- オフィス系ソフト
- エクセル マクロ
エクセルのある特定のセルをダブルクリックすると 画像ファイルを参照しにいき 貼りつけたい画像ファイル選ぶと そのセルの大きさに合わせて 画像ファイルがそのセルに 貼りつくというマクロが以下の通りなんですが Excel2003からExcel2007へ変更すると 画像ファイルの貼りつく位置がダブルクリックしたセルではない所に 貼りつくようになりました 参照や大きさなどはちゃんと機能しているようです どこを変更すればよいでしょうか？ Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range('特定のセル)) Is Nothing Then Exit Sub Cancel = True Dim myPic Dim myRange As Range Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 .Top = .Top + (myRange.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True End Sub
- ベストアンサー
- オフィス系ソフト
- エクセル2007のマクロについて
B9に品番を入力するとA9に画像が自動挿入される所まではなんとか出来たのですが、 同じくB10,B11,B12・・・と下の行にも同じように品番を入力すれば画像が自動挿入される様にするには,どうのようにすれば良いのでしょうか？宜しくお願い致します。 A B 9 画像 品番 10 画像 品番 11 画像 品番 12 画像 品番 ・ ・ ・ Private Sub Worksheet_Change(ByVal Target As Range) Const ImagePath = "C:\Users\f\Desktop\画像\" If Intersect(Target, Range("B9")) Is Nothing Then Exit Sub Application.EnableEvents = False Dim codRange As Range Set codeRange = Range("B9") Dim picRange As Range Set picRange = Range("A9") Dim objPic As Picture For Each objPic In ActiveSheet.Pictures If objPic.Left >= picRange.Left And objPic.Left <= picRange.Left + picRange.Width _ And objPic.Top >= picRange.Top And objPic.Top <= picRange.Top + picRange.Height Then objPic.Delete Exit For End If Next picPath = ImagePath & codeRange.Value & ".jpg" If Dir(picPath, vbNormal) = "" Then picRange.Cells(1, 1).Value = "画像がありません" Else picRange.Select Sheets(1).Pictures.Insert(picPath).Select '画像ファイルの挿入 With ActiveSheet.Pictures(ActiveSheet.Pictures.Count).ShapeRange .LockAspectRatio = msoFalse .Parent.Visible = msoTrue .Left = picRange.Left .Top = picRange.Top .Height = picRange.Height .Width = picRange.Width End With picRange.Cells(1, 1).Value = "" End If Application.EnableEvents = True End Sub
- 締切済み
- オフィス系ソフト
お礼
さっそくありがとうございました。 なるほど、名前を付けて、その名前のオートシェイプを削除するわけですね。 やってみました。 うまくいきます。しかし、連続して１を入れるとどんどんハートが重なりますし、連続して1以外だと、重なったハート無くなればエラーになります。 どうすればいいでしょうか？