• 締切済み

ExcelVBAでオートシェイプラインを変更したい

Excel2013を使用しています。表中の空欄にShapeを使って斜めにラインを引いていますが、この線をデータのカウントに合わせて上端を変化させたい。AddLineにて線を挿入するコードとマクロでのSelection.ShapeRange.ScaleWidth 1.3605442177, msoFalse, msoScaleFromBottomRight 'Selection.ShapeRange.ScaleHeight 0.7500001875, msoFalse, _では希望通りできますが、いちいちポイントをつかまなくてはなりません。名前を付けたラインをセレクトして「I27(右上)~B31(左下固定)」等と上端を変化できる方法を教えてください。

みんなの回答

回答No.2

こんにちは。 返事が遅くなりました。 マクロ自体は早速作ってしまったのですが、オヤっと思って、確認の必要がありました。 そして、そのままになってしまい、申し訳ありません。 使い方としては、必要な場所を、まず範囲設定してから、以下のマクロの実行をすれば、前にあった罫線などは削除されて、新たに線を引きます。ポイント(角)という考え方ではなく、あくまでも、セル(連結を含む)部分の左下と右上を結ぶように出来ています。実務的には、右クリック・イベントに設けるのが一番便利かと思います。 '// Sub TestLine() Dim shp As Shape  For Each shp In ActiveSheet.Shapes   If Not Intersect(Selection, shp.TopLeftCell) Is Nothing Then     shp.Delete   End If  Next  Call SetLine(Selection) End Sub Function SetLine(rng As Range) Dim Lf As Double, Tp As Double, Wd As Double, Ht As Double Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double With rng   Lf = .Cells(1).Left   Tp = .Cells(1).Top   Wd = .Cells(1, .Columns.Count + 1).Left - .Cells(1).Left   Ht = .Cells(.Rows.Count + 1, 1).Top - .Cells(1).Top End With  x2 = Lf + Wd: y2 = Tp  x1 = Lf: y1 = Tp + Ht With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2).DrawingObject   .ShapeRange.Fill.Visible = msoFalse   .ShapeRange.Line.Weight = 0.75   .ShapeRange.Line.DashStyle = msoLineSolid   .ShapeRange.Line.Style = msoLineSingle   .ShapeRange.Line.Transparency = 0# End With End Function '//

回答No.1

こんにちは。 一度、マクロは考えたのですが、読みなおしてみると、こちらが勇み足になる可能性があったので、コードのアップは取りやめにしました。 >名前を付けたラインをセレクトして「I27(右上)~B31(左下固定)」等と上端を変化できる方法を教えてください。 「名前を付けたライン」とは、名前などを付けてしまったのでしょうか。 「I27(右上)~B31(左下固定)」とは、ひとつの範囲だけを指すとは思いにくいのですが。言い換えれば、汎用性がなくては、意味がないし、その範囲の元になるのは、四角形(rectangle)という意味ではないでしょうか。 「いちいちポイントをつかまなくてはなりません。」のポイントとは、表計算上にそのような部分が置かれているのでしょうか。一旦は、四角形の左下の角から右上の角を点と点を結ぶものと考えましたが、分からなくなりました。 その斜めに引いた線が、ずれているか、結果的にはずれてしまったと、当初は解釈しました。 しかし、図形(四角形など)内のライン(直線)は他の図形とConnectしていれば、図形の変化に対応するはずなので、ご質問の意味が分からなくなりました。

dedebow
質問者

補足

windFallerさんご検討ありがとうございます。たとえば請求書の〆の線のように以下空白であれば左斜め下に向かってラインを引くことを想定しています。セル結合していますので罫線では解決できません。コードでAddLineを使い線を挿入することでは「角」をとらえて線を引くことができました。しかし、次は削除しないと追加されていくだけになります。また、ポイントは挿入→図形→直線からマクロを記録するとポイントでコードが記録されます。このポイントを変化させることで可能ですが大変です。わかりづらくて申し訳ありません。

関連するQ&A

  • Excel VBA シェイプの原型のサイズ取得方法

    VBAでシェイプの縦横比を%指定で変更したく、下記のように書いています ActiveSheet.Shapes("Picture 208").Select Selection.ShapeRange.LockAspectRatio = msoFalse Selection.ShapeRange.ScaleWidth 2, msoFalse '横2倍の大きさに ところが、ScaleWidthが見ている数値が元の図形のものと違うようです。原因を探すためにシェイプの原型のサイズ(幅や高さの数値)を知りたいのですが、VBAからアクセスできるプロパティやメソッドはあるでしょうか?

  • エクセル マクロで画像を指定したコマへ移動する

    よろしくお願いします。 マクロは触ったばかりです。 何度も検索をかけたのですがどうしても うまくヒットさせることが出来ず こちらで相談させて頂くことにしました。 画像を毎回決まった大きさにトリミングし その後 その画像の左端をセルB17に移動させたいのですが マクロの記録で行うと 右へどれくらい、左へどれくらいと 指定されてしまい必ず同じ場所へ移動してくれません。 「その画像の左端をセルB17に移動」 このコードを教えてください。 出来上がっているコードは Selection.ShapeRange.PictureFormat.CropBottom = 224.39 Selection.ShapeRange.PictureFormat.CropTop = 21.6 Selection.ShapeRange.PictureFormat.CropRight = 11.4 Selection.ShapeRange.PictureFormat.CropLeft = 9.6 Selection.ShapeRange.ScaleWidth 0.76, msoFalse, msoScaleFromBottomRight Selection.ShapeRange.ScaleHeight 0.76, msoFalse, msoScaleFromTopLeft End Sub ここまでです。 (右へどれくらい移動というのは 消しました。) よろしくお願いします。

  • エクセルで簡単なオートシェイプのマクロをつくりました マクロの実行とステップごとの実行の結果がちがってしまいます

    オートシェイプを使った簡単な寸法線の入った図をマクロで書きました。 ステップごとだと期待どおりのアウトプットなのですが、ダイレクトにマクロを実行すると途中のステップがとんでしまうようです。 どうしてでしょうか。 教えてください。 1 Sub 寸法線1() 2 Dim l1, l2, l3, l4, lb, la1, la2, fig1, fig2, fig3, fig4 As Shape 3 x1 = 200 4 y1 = 500 5 x2 = x1 + 100 6 k = Cells(7, 5).Value / Cells(7, 4).Value 7 y2 = y1 - 100 * k 8 Set l1 = ActiveSheet.Shapes.AddLine(x1, y1, x2 + 20, y1) 9 Set l2 = ActiveSheet.Shapes.AddLine(x1, y1, x1, y2 - 15) 10 Set lb = ActiveSheet.Shapes.AddLine(x1, y1, x2, y2) lb.Line.Weight = 2# 11 Set l3 = ActiveSheet.Shapes.AddLine(x2 + 5, y2, x2 + 20, y2) 12 Set l4 = ActiveSheet.Shapes.AddLine(x2, y2 - 5, x2, y2 - 15) 13 Set la1 = ActiveSheet.Shapes.AddLine(x2 + 12.5, y1 - 2, x2 + 12.5, y2 + 2) 14 la1.Line.BeginArrowheadStyle = msoArrowheadTriangle 15 la1.Line.BeginArrowheadLength = msoArrowheadLengthMedium 16 la1.Line.BeginArrowheadWidth = msoArrowheadWidthMedium 17 la1.Line.EndArrowheadStyle = msoArrowheadTriangle 18 la1.Line.EndArrowheadLength = msoArrowheadLengthMedium 19 la1.Line.EndArrowheadWidth = msoArrowheadWidthMedium 20 Set la2 = ActiveSheet.Shapes.AddLine(x1 + 2, y2 - 10, x2 - 2, y2 - 10) 21 la2.Line.BeginArrowheadStyle = msoArrowheadTriangle 22 la2.Line.BeginArrowheadLength = msoArrowheadLengthMedium 23 la2.Line.BeginArrowheadWidth = msoArrowheadWidthMedium 24 la2.Line.EndArrowheadStyle = msoArrowheadTriangle 25 la2.Line.EndArrowheadLength = msoArrowheadLengthMedium 26 la2.Line.EndArrowheadWidth = msoArrowheadWidthMedium 27 Set fig1 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _ x1 - 10, y1 + 5, 17, 17) 28 fig1.Select 29 Selection.Characters.Text = Str(Cells(6, 3)) 30 Selection.Characters.Font.Bold = True 31 Selection.ShapeRange.Line.Visible = msoFalse 32 Set fig2 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _ x2 + 5, y2 - 20, 18, 18) 33 fig2.Select 34 Selection.Characters.Text = Str(Cells(7, 3)) 35 Selection.Characters.Font.Bold = True 36 Selection.ShapeRange.Line.Visible = msoFalse 37 Set fig3 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _ x1 + (x2 - x1) * 0.5 - 13, y2 - 32, 45, 17) 38 fig3.Select 39 Selection.Characters.Text = Str(Cells(7, 4)) 40 Selection.ShapeRange.Line.Visible = msoFalse 41 Set fig4 = ActiveSheet.Shapes.AddTextbox(msoTextOrientationUpward, _ x2 + 15, y1 - 0.5 * (y1 - y2) - 8, 17, 45) 42 fig4.Select 43 Selection.Characters.Text = Str(Cells(7, 5)) 44 Selection.ShapeRange.Line.Visible = msoFalse 45 MsgBox "pause" 46 Call l1.Select 47 Call l2.Select(False) 48 Call l3.Select(False) 49 Call l4.Select(False) 50 Call lb.Select(False) 51 Call la1.Select(False) 52 Call la2.Select(False) 53 Call fig1.Select(False) 54 Call fig2.Select(False) 55 Call fig3.Select(False) 56 Call fig4.Select(False) 57 MsgBox "hit any" 58 Selection.ShapeRange.Group.Delete 59 End Sub Cells(7, 5)=50 cells(7,4)=100 cells(6,3)=1 cells(7,3)=2 です。 左端に行番号をふってあります。 36から44まで飛んでしまいます。 節点 座標 X Y 1 0 0 2 100 50

  • 挿入した画像を等倍ではなく、サイズを指定したい

    Sub Macro1() ActiveSheet.Pictures.Insert( _ "C:\Users\画像.gif").Select With Selection.ShapeRange .ScaleWidth 1, msoFalse, msoScaleFromTopLeft .ScaleHeight 1, msoFalse, msoScaleFromTopLeft End With End Sub これで画像を挿入し、サイズを変更してるのですが 1だと等倍になってしまうようです。 常に1cmとか、サイズを指定して変更するプロパティはありますか?

  • Excel-VBA コメントの書式設定

    Excel-VBA コメントの書式設定 コメントの書式設定をExcel-VBAで定義したい。 従い「マクロの記録」を実行して下記のソースコードを取得しました。 これを実行すると次の実行エラーが発生しました!? ★正常に動作させるソースコードの事例をいただければ幸いです。 ご指導よろしくお願いいたします。 実行時エラー'438' オブジェクトは、このプロパティまたはメソッドをサポートしていません。 Sub Macro1() ' 処理:マクロの記録 ' 目的:「コメントの挿入」と「コメントの書式設定」をする。 Range("A2").Select Range("A2").AddComment Range("A2").Comment.Visible = False Range("A2").Comment.Text Text:="コメント" & Chr(10) & "今日は良いお天気ですね。" '▽次で実行エラーが起きる!? Selection.ShapeRange.ScaleWidth 1.58, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.ScaleHeight 1.49, msoFalse, msoScaleFromTopLeft Selection.ShapeRange.Fill.Visible = msoTrue Selection.ShapeRange.Fill.Solid Selection.ShapeRange.Fill.ForeColor.SchemeColor = 9 Selection.ShapeRange.Fill.Transparency = 0# Selection.ShapeRange.Line.Weight = 0.75 Selection.ShapeRange.Line.DashStyle = msoLineSolid Selection.ShapeRange.Line.Style = msoLineSingle Selection.ShapeRange.Line.Transparency = 0# Selection.ShapeRange.Line.Visible = msoTrue Selection.ShapeRange.Line.ForeColor.RGB = RGB(0, 0, 0) Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255) Selection.ShapeRange.LockAspectRatio = msoTrue Selection.ShapeRange.Height = 141.75 Selection.ShapeRange.Width = 283.5 Range("A1").Select End Sub

  • エクセル2002マクロ オートシェイプの消去方法を教えて下さい

    エクセルでB5~F18に掛けて表があります。 この表は毎日1表ずつ分あり、使わない日は右上から左下に向かって斜線を引きます。 オートシェイプで引いた線をマクロで記録して引いているのですが、誤って引いてしまった時の消去マクロが作れないかな、と考えているのですが、可能でしょうか? マクロの記録で、オートシェイプをクリックしてDeleteとやってみたのですが、うまくいきません。 どうやら線を引くたびに番号がつくらしく、その番号の線を消す、という風に記録してしまう為、エラーになってしまうようです。 表に斜線が引ければ良い訳で、他に方法があるのならそれで構いませんし、表は印刷してペーパーで保管しています。 何か良い方法がありましたら、宜しくお願い致します。 ちなみに今、描写の為に使っているマクロは下記の通りです。 Sub Macro2() ActiveSheet.Shapes.AddLine(15.75, 59.25, 323.25, 475.5).Select Selection.ShapeRange.Flip msoFlipHorizontal End Sub

  • VBAでオートシェイプのグループ化についての質問です。

    VBAでオートシェイプのグループ化についての質問です。 オートシェイプ線(Line)で台形を作成し全てを選択し、グループ化したいと考えています。 また、連続して台形を作成していきたいと考えています。 ?4本線を引く ?グループ化(Aグループ) ?4本線を引く ?グループ化(Aグループ)  ⇒ 連続して作成・・・ Dim st() As Variant Dim ob As Shape Dim MyLine As Shape '線の作成 Set MyLine = ActiveSheet.Shapes.AddLine(startX, startY, widthX, heightY) '線の選択 For Each ob In ActiveSheet.Shapes   ReDim Preserve st(j)   st(j) = ob.name   j = j + 1 Next ob 'グループ化 Worksheets("test").Shapes.Range(st).Select Selection.ShapeRange.Group.Select と上記コードで一つのグループは作成出来たのですが、次に作成すると Worksheets("test").Shapes.Range(st).Select Selection.ShapeRange.Group.Select でエラーになります。 恐らく前のグループ化内の線も選択してしまうのではないかと思っていますが、対処の仕方が解りません。 線の作成方法から選択方法等いろいろ意見が聞きたいと思っています。 アドバイスよろしくお願いいたします。 m(__)m

  • Word2003でオートシェイプ高さを3mm程度に

    Word2003 SP3で、オートシェイプを選択し、 Alt+ドラッグ操作で高さを小さくしていっても4.85mmで頭打ちになり それ以上小さくできません。 ・同じ操作で幅は、3.18mmまでは小さくできます。 ・オートシェイプの書式設定ダイアログで値を直接指定すれば もっと小さくできますが、毎回そんな手間が掛かっては話になりません。 (それで高さを3mmにしても、その後ドラッグで幅調節しようとすると、  高さが4.85mmに押し戻されてしまう) ・同じ環境でも書類によっては、3.18mmまで小さくできます。 ・シェイプ内のテキスト有無や線の太さは関係ないようです。 ●書類によって4.85mmで頭打ちになる現象を解決できないでしょうか? 妥協策として、以下のようなマクロを組んで、ショートカットキーに 割り当て、平易に高さ調節できるようにしてみたのですが、 描画キャンバス内にあるオートシェイプを選んで操作した時に 描画キャンバス全体が(操作対象となって)小さくなってしまいます。 ●描画キャンバス内で選択したオートシェイプのみを対象に  操作が適用されるようにする方法はないものでしょうか? Sub オートシェイプ高さを小さくする() If Selection.Type <> wdSelectionShape Then End Selection.ShapeRange.Height = Selection.ShapeRange.Height - 1 End Sub

  • Word2007マクロ

    宜しくお願い致します Word2007でこんな事が出来ますか Excel2007で線路を作るマクロを作成しました(本を見て) これをWordでも使用したいのですが、Excelのマクロそのまま WordのVisual Basicに書き込んでもエラーが出て機能しません Excelのマクロは以下です Sub 線路作成() 上端位置 = Selection.Top 左端位置 = Selection.Left  Selection.ShapeRange.Line.Weight = 6# Selection.ShapeRange.Line.Visible = msoTrue Selection.ShapeRange.Line.Style = msoLineSingle Selection.ShapeRange.Duplicate.Select Selection.ShapeRange.IncrementLeft -18# Selection.ShapeRange.IncrementTop 9.6 Selection.ShapeRange.Line.DashStyle = msoLineDash Selection.ShapeRange.Line.Weight = 4.5 Selection.ShapeRange.Line.Visible = msoTrue Selection.ShapeRange.Line.Style = msoLineSingle Selection.ShapeRange.Line.ForeColor.SchemeColor = 9 Selection.ShapeRange.Line.Visible = msoTrue Selection.Top = 上端位置 Selection.Left = 左端位置 End Sub Wordで使えるようにするには、どこを直せばよいでしょうか。

  • PowerPointのVBAで、図形を縮小後、画質を落とさずに出力する方法

    PowerPointのVBAで、スライド上の図形のサイズを縮小した後、この図形をjpg画像として保存したいです。 オペレーションはこんな感じです↓ 図形縮小→図形を選択→右クリック→[図として保存]→JPGファイル名で保存 上記操作を「マクロの記録」で記録したものを実行すると、スライド全体が保存されてしまいます。 また、マクロで.ShapeRange.Exportで画像出力すると、画質が荒くなって出力されます。 画質を落とさず、図形をjpgとして保存する方法はないでしょうか。 よろしくお願い致します。 以下が、現状の私のプログラムです。 Sub Macro() ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:="C:\aaaa.JPG", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=-119, Top:=-89, Width:=960, Height:=720).Select ActiveWindow.LargeScroll ToRight:=1 With ActiveWindow.Selection.ShapeRange .ScaleWidth 0.25, msoFalse, msoScaleFromTopLeft .ScaleHeight 0.25, msoFalse, msoScaleFromTopLeft End With With ActiveWindow.Selection.ShapeRange .IncrementLeft 219.12 .IncrementTop 416.75 End With ActiveWindow.Selection.ShapeRange.Select 'これだと画質が落ちます。↓ Call ActiveWindow.Selection.ShapeRange.Export("C:\\bbb.jpg", ppSaveAsJPG) 'これだとスライド全体が保存されます。↓ ' ActivePresentation.SaveAs FileName:="C:\bbb.jpg", FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse End Sub

専門家に質問してみよう