• ベストアンサー

選択したセルにピッタリ合うオートシェイプの挿入

よろしくお願いいたします。 下記のコードは行方向では選択したセルとピッタリに四角のオートシェイプが挿入できるのですが、列方向では常に1行です。 横方向も選んだ範囲だけ広がるようにするにはどう変えたらよいでしょうか。 Set shrect = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _ Selection.Left, Selection.Top, Selection.Offset(0, 1).Left - Selection.Left, _ Selection.Height)

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

  • ベストアンサー
  • HohoPapa
  • ベストアンサー率65% (454/690)
回答No.3

>ところで、もう一つお願いしてもよろしいでしょうか。 ツイデの質問で答えられるほど単純ではありません。 貼り付けた図の上に任意なテキストを入力可能な部品を。 とのことですので テキストボックスを貼り付けることとなりましょう。 だとすると、 その高さ、幅、位置、背景色、文字フォントのサイズなどを どのように決めればいいのかがが明示されないと コードを示すことが困難です。 これらを明らかにして、再質問してください。 識者が回答してくれる思います。

ticktak
質問者

お礼

失礼しました。 別に質問させていただきます。ありがとうございます。

その他の回答 (2)

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

#1のご回答と内容は、同じだが、 Sub test01() t = Cells(2, "B").Top l = Cells(2, "B").Left w = Cells(2, "B").Width + Cells(2, "C").Width + Cells(2, "D").Width h = Cells(2, "B").Height '-- Set shrect = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _ l, t, w, h) End Sub のようにすれば、幅は如何様にもなるのでは。 上記ではB,C、D列3列の幅の合計例。連続した整数個の列幅にするもの。 l, t, w, h)の順序を間違えないように。 それか、名前付き引数で指定するとか。

ticktak
質問者

お礼

お忙しいところご教示いただきありがとうございます。 参考にさせていただきます。

  • HohoPapa
  • ベストアンサー率65% (454/690)
回答No.1

以下はいかがでしょうか? Set shrect = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _ Selection.Left, Selection.Top, Selection.Width, _ Selection.Height)

ticktak
質問者

お礼

どうもありがとうございました。答えを聞くと。。。簡単にできるものなのですね。もっと勉強しなきゃって思います。 ところで、もう一つお願いしてもよろしいでしょうか。 この四角の中に文字を記入したいのですが、四角を挿入後すぐにタイプして文字が四角の中に入るようにするにはどうすればいいでしょうか。

関連するQ&A

  • 挿入したオートシェイプが文字入力待機状態にする方法

    昨日HohoPapaさんに選択したセルとピッタリ合うオートシェイプの挿入の仕方を教えていただきました。 今度は、オートシェイプがアクティブ状態とでもいうのでしょうか、挿入後すぐにタイプしたら文字が入力できる状態にする方法を教えていただきたいです。フォントのサイズ、位置は不問で黒色で入力できればと思います。 よろしくお願いいたします。 Set shrect = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _ Selection.Left, Selection.Top, Selection.Width, _ Selection.Height) shrect.Fill.ForeColor.SchemeColor = 22 'Grey 'shrect.Font.Color = vbBlack ←うまくいかなかった部分

  • #の意味

    エクセルでオートシェイフ゜のマクロの記録をとったときに Sub Macro2() ActiveSheet.Shapes.AddShape(msoShapeFlowchartConnector, 100, 100#, 100, 100).Select End Sub のように TOPの後にシャーフ゜が入ります。 (expression.AddShape(Type, Left, Top, Width, Height)) これはどういう意味でしょうか? シャーフ゜があってもなくても新規のオートシェイフ゜が挿入できます。

  • VB6 オートシェイプ描画

    VB6 オートシェイプ描画 VB6でExcel,2000(ActiveSheet)にオートシェイプを使用したいのですが、エラーが出てしまいます。 コマンドボタンクリック時、エラー ------------------------------- 実行時エラー'1004': 指定された値は境界を超えています。 ------------------------------- AddLineは出来たのですが四角や円がこのエラーです。どこが間違えているのでしょうか? 宜しくお願いします。 Private Sub CB13_Click() Dim xlApp As Excel.Application Set xlApp = GetObject(, "Excel.Application") xlApp.ActiveSheet.Shapes.AddLine 50, 50, 100, 100 '(OK) xlApp.ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 100).Select '(NG) Set xlApp = Nothing End Sub

  • ShapeのVBAの中での取り扱い

    ShapeのVBAの中での取り扱いに関して、サジェスチョン願います。 Shapeに文字が書き込まれていない段階で、選択して文字を読み込み判定しようとするとエラーとなります。 下記のVBAでは、5番目のShapeが該当します。 このエラーを防ぐためには、On Error Resume Nextが有効ですが、他の方法を探しています。例えば、charactor=trueみたいなもの。 ----- Sub Shapeの調査() Dim nametemp(10) As String Dim temp As Integer Dim i As Integer Dim aaa As Variant 'On Error Resume Next ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeOval, 100, 100, 50, 50).Select ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 150, 150, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeRectangle, 200, 200, 50, 50).Select ActiveSheet.Shapes.AddShape(msoShapeOval, 250, 250, 50, 50).Select temp = ActiveSheet.Shapes.Count For i = 1 To temp ActiveSheet.Shapes(i).Select nametemp(i) = ActiveSheet.Shapes(i).Name Next For i = 1 To temp / 2 + 1 '4つのshapeに対し、文字を書き込もうとする ActiveSheet.Shapes(nametemp(i)).Select Selection.Characters.Text = "" Next For i = 1 To temp / 2 '3つに対して、文字を書き込む ActiveSheet.Shapes(nametemp(i)).Select Selection.Characters.Text = "zzzzz" Next For i = 1 To temp ActiveSheet.Shapes(nametemp(i)).Select aaa = Selection.Characters.Text '<--5番目のShapeに対し If aaa = "zzzzz" Then MsgBox (aaa)'<--errorとなる。 Next End Sub

  • JavaScriptで書き出したオートシェイプにテキストを挿入したいの

    JavaScriptで書き出したオートシェイプにテキストを挿入したいのですができません。 先日、ExcelのシートにJavaScriptでオートシェイプを書き出す方法を質問した者です。 今度は書き出したオートシェイプにテキストを挿入したいのですが上手くいきません。 どうすれば良いのか教えてください。 ※またもやJavaScriptで解決したいです。 なお、現在悩み中のソースは以下のようです。 ※教えて頂いたソースほとんどそのままですが... function createShapes() { var excel = new ActiveXObject( "Excel.Application" ); excel.visible = true; var sheet = excel.Workbooks.Add().activeSheet; // オートシェイプ挿入:引数の105は吹き出しを示す sheet.Shapes.AddShape(105, 123, 37.5, 151.5, 94.5); // ココでメソッド、プロパティがないとエラーになってしまう...  sheet.Shapes("AutoShape 1").Characters.Text = "ほげほげ"; } よろしくお願いします。

  • Excelでグループ化したオートシェイプにテキストを編集するコード

    Excelの四角のオートシェイプで、例えば、「四角1」「四角2」「四角3」という名前のオートシェイプが3つあったとしてテキスト編集で同じ文字列を入れたいとき、 For a = 1 To 3 ActiveSheet.Shapes("四角" & a).Select Selection.Characters.Text = "文字列" Next a とすればできるのですが、「四角1~3」をグループ化し、名前を「四角」としたとき、 ActiveSheet.Shapes("四角").Select Selection.Characters.Text = "文字列" とするとエラーが出てしまいます。グループ化されたオートシェイプのテキスト編集は、一度グループを解除し、それぞれテキスト編集しなければならないのでしょうか? 回答よろしくお願いします。

  • エクセル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に入力されるデータが1,2,3,4の4種類、AQ11に5,6,7,8,9の5種類などと、ばらばらです。 P11に1が入力されるとN14:N15(結合されています)に円が入り、2が入力されるとN16に円が入る。 Q11に5が入力されるとR13に円が入り、6が入力されるとR14:R15に円が入る・・・・のようにしたいのです。 一生懸命、セルNo.を打ち込んでいたら、 「コンパイルエラー:プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。

  • excelVBAのオートシェイプ幅設定について

    いつもお世話になっております。 以前こちらでお教えしてもったVBAを試してみたのですが、うまくいきません。 自分なりに調べてきたつもりですが、オートシェイプの幅を時間と結びつけるやり方がよくわかりません。 A2=14:30 A3=15:15 A4=45      B  C  D … 3行目 0   1  2  … で、4行目に、A2~A3のオートシェイプを時間の列と対応するよう作成したいのですが、幅が長くなりすぎてしまいます。 Columns("A:Z").ColumnWidth = 9 変数S = Cells(4, 2) 変数E = Cells(4, 25) ★変数Width = 変数E.Left + 変数E.Width - 変数S.Left 変数Height = 変数E.Height 変数Top = 変数S.Top ★変数Min = 変数Width / 1440 ★変数Start = Cells(1, 2).Value * 1440 * 変数Min + 変数S.Left 変数End = Cells(1, 3).Value * 24 ★変数2Width = Cells(1, 4).Value * 変数Width ActiveSheet.Shapes.AddShape(msoShapeRectangle, 変数Start, 変数Top, 変数2Width, 変数Height).Select となっていますが、 ★部分がよくわかりません。 変数Width = 変数E.Left + 変数E.Width - 変数S.Left を求めて、なぜ、A4に*ことになるのか。 1440はどこからきた数字なのか。 そもそもこの式自体が間違っているのでしょうか。 トンチンカンな質問になっていたら申し訳ございません。 よろしくお願いします。

  • VBA シート上のボタンクリックしたら実行

    お世話になっております。 シート上に、予定1、予定2…        実際1、実際2… という名前で作成したオートシェイプがあります。 このオートシェイプをクリックしたら、 既にあるオートシェイプ(矢印)を消し、 オートシェイプ(矢印)を作成するというものをしたいと思っています。 -------------------------- Sub Test() Dim TESTShape As Shape Dim i As Long Dim j As Long j = 1 For i = 5 To 64 With ActiveSheet.Range("J" & i) If i Mod 2 = 1 Then '2で割って余りが1なら Set TESTShape = ActiveSheet.Shapes.AddShape( _ msoShapeRectangle, _ Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height) TESTShape.Fill.Visible = msoTrue TESTShape.Select Selection.ShapeRange.Fill.ForeColor.SchemeColor = 41 TESTShape.Name = "予定" & j ' Else Set TESTShape = ActiveSheet.Shapes.AddShape( _ msoShapeRectangle, _ Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height) TESTShape.Name = "実際" & j ' j = j + 1 End If End With Next End Sub -------------------------- 上記プログラムで、シート上にボタンを作成しました。 そのシートに直接プログラムを書き込み? Private Sub 予定1_Click() MsgBox "TEST" End Sub と試してみていますが、オートシェイプから シートプログラム?の実行はできないのでしょうか。 このシートは色んなシートにコピーして使おうと思っているため、 ボタンをおしたら矢印を消したり、追加したりする動作も他のブックにコピーしたいと思っています。 そのためシートに書き込もうとしているのですが、上手く行かず… 根本的に、なにか間違っているかもしれません。 シートに書き込むプログラムをどう書くべきなのかあまり良くわかっておりません…。 シート上のボタンをクリックしたら実行できるのは、 標準モジュールに書き込んだプログラムのみなのでしょうか? 質問がわかりにくく、説明不足の点も多々あるかもしれません。 その場合は、どんどん聞いてください。お願いします。 回答お待ちしております。

  • 特定の名前のオートシェイプの有無を知りたい(エクセルVBA)

    Excel VBA で、オートシェイプを扱おうとしています。 たとえば、 ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 10, 50, 50).Name = "TestShape1" のようにして、それぞれ名前を付けているのですが、プログラム中、特定のオートシェイプを削除したり、再び同じ名前で作ったり、ということを行っています。 前者の場合、すでに当該オートシェイプが削除されている場合、目的のオートシェイプが存在していないためか、エラーが発生します。また後者の場合も、オートシェイプを重ねて作成することになってしまうケースにエラーが発生します。 On Error Resume Next で回避することも考えられるでしょうが、もっと直接的に、ある名前のオートシェイプが存在する/しない、をチェックしたうえで各処理を行うようにしたいのです。 どのような方法があるでしょうか?

専門家に質問してみよう