エクセルの学校：全文検索：Hyper Estraier：オートシェイプ

Results of 1 - 1 of about 1039 for オートシェイプ (0.001 sec.)

[[20090417160332]]: #score: 6703; @digest: 78841c59de65116163ee99082beedfa1; @id: 43004; @mdate: 2009-04-21T23:32:26Z; @size: 7859; @type: text/plain; #keywords: spnm (22862), msosendtoback (22473), zorder (11984), ィッ (9626), msofalse (9097), シェ (6323), ェイ (5953), picture (5192), lockaspectratio (4985), copypicture (4911), rng (4818), 在ア (4775), イプ (4411), height (3934), weight (3610), prompt (3536), shapes (3521), width (3406), トシ (2614), ト用 (2539), 数セ (2475), activesheet (2412), sp (2326), parent (2319), flg (2300), visible (2262), shape (2088), ichinose (2066), inputbox (1932), 用シ (1804), 作動 (1546), nothing (1451); 『セル内にオートシェイプをフィットさせる』（どら）
セル内に接する円のオートシェイプを描くのをここで先日教えて頂きましたが、Picture 16のオートシェイプを、この円の変わりにフィットさせたいのですが、お願い致します。日にちもたって、内容も変わってしまったので、新しくアップしました。下は、セル内に接する円のもので、 ActiveSheet.Shapes.AddShape(msoShapeOval, rng.Left, rng.Top, _ rng.Width, rng.Height).Select の部分を変えるのでしょうが、わかりませんのでお願い致します。 Sub test() Dim sp As Shape, flg As Boolean Dim obj As Object, rng As Range Set rng = Application.InputBox(Prompt:="○を入れるセルを選択して下さい", Type:=8) If Not rng Is Nothing Then flg = False For Each sp In ActiveSheet.Shapes If sp.TopLeftCell.Address(0, 0) = "A1" Then flg = True sp.Delete Exit For End If Next If Not flg Then ActiveSheet.Shapes.AddShape(msoShapeOval, rng.Left, rng.Top, _ rng.Width, rng.Height).Select With Selection.ShapeRange .Fill.Visible = msoFalse .Line.Weight = 0.5 .ZOrder msoSendToBack End With rng.Select Set rng = Nothing End If End If End Sub ---- Picture 16というShapeオブジェクトは、既にアクティブシートに存在しているという事ですね? Sub test() Dim sp As Shape, flg As Boolean Dim obj As Object, rng As Range Const spnm = "Picture 16" Set rng = Application.InputBox(Prompt:="○を入れるセルを選択して下さい", Type:=8) If Not rng Is Nothing Then flg = False For Each sp In ActiveSheet.Shapes If sp.TopLeftCell.Address(0, 0) = "A1" Then flg = True sp.Delete Exit For End If Next '↑この辺りのコードの必要性の有無は仕様が分かりませんのでそのまま残しておきました。 If Not flg Then With ActiveSheet.Shapes(spnm) .Left = rng.Left .Top = rng.Top .Width = rng.Width .Height = rng.Height .Fill.Visible = msoFalse .Line.Weight = 0.5 .ZOrder msoSendToBack End With rng.Select Set rng = Nothing End If End If End Sub ichinose ---- 高さ方向にフィットして、幅方向はその比率に応じて変化する様です。』（どら）幅方向もフィットさせたいのですが可能でしょうか。それと、セル結合されたセルにもフィットさせたいのですが。わがまま言ってすみません。 1).Width = rng.Width 2).Height = rng.Height 1)2)を逆にすると、幅にフィットして、高さ方向は、その比率変化する様ですが意味が分かりません。 ---- If Not flg Then With ActiveSheet.Shapes(spnm) .LockAspectRatio = msoFalse 'これを追加して試してみて!! .Left = rng.Left .Top = rng.Top .Width = rng.Width .Height = rng.Height .Fill.Visible = msoFalse .Line.Weight = 0.5 .ZOrder msoSendToBack End With rng.Select Set rng = Nothing End If ichinose ---- ichinoseさんフィットしました。複数セルを選択してもOKでした。結合セルのみ頭のセルにフィットしますが、使い方で複数セルに対応で十分です。どうもありがとうございました。（どら） ---- 貼り付ける際の事でまた教えて下さい。（どら）シェイプを他の新しいシートに作成してマクロを実行する前のシートを Application.InputBoxで選択するとrng.Selectでrangeクラスのselect メゾットが失敗しましたとエラーしますが、どの様に対処すれば良いですか? Sub test() Dim sp As Shape, flg As Boolean Dim obj As Object, rng As Range '新しいシートにシェイプを作成する Sheets.Add Range("B1") = "テスト用シェイプ" Range("B1").CopyPicture Appearance:=xlScreen, Format:=xlPicture ActiveSheet.Paste Const spnm = "Picture 1" Set rng = Application.InputBox(Prompt:="シェイプを入れるセルを選択して下さい", Type:=8) If Not rng Is Nothing Then If Not flg Then With ActiveSheet.Shapes(spnm) .LockAspectRatio = msoFalse .Left = rng.Left .Top = rng.Top .Width = rng.Width .Height = rng.Height .Fill.Visible = msoFalse .Line.Weight = 0.5 .ZOrder msoSendToBack End With rng.Select Set rng = Nothing End If End If End Sub ---- >rng.Selectでrangeクラスのselectメゾットが失敗しましたとエラーしますが別シートのセルを選択する場合は、親オブジェクトから、順に選択しなければエラーになってしまいます。例1 現在アクティブなシ-トがSheet1の時にSheet2のセルA1を選択したい場合、 worksheets("sheet2").activate range("a1").select 例2 現在アクティブなシ-トがBOOK1のSheet1の時にBook2のSheet2のセルA1を選択したい場合、 workbooks("book2").activate worksheets("sheet2").activate range("a1").select よって、今回のrngの場合、 With rng .Parent.Parent.Activate .Parent.Activate .Select End With なんてすると、正常に作動します。が、面倒ですね Application.Goto rng このようにすると、1行で解決します。これで投稿されたエラーは解決しますが、果して正常に作動しますか? これ「テスト用シェイプ」と書かれた図形を指定されたセル範囲(違うシートや違うブックの場合もある）に移すという仕様ですよね? もしそうだとしたら、シートが違うセル範囲を選択すると今のままでは、正常に作動しませんよ!! 以下のようにして試してみてください。 '======================================================================== Sub test() Dim sp As Shape, flg As Boolean Dim obj As Object, rng As Range '新しいシートにシェイプを作成する ActiveSheet.Select Sheets.Add Range("B1") = "テスト用シェイプ" Range("B1").CopyPicture Appearance:=xlScreen, Format:=xlPicture ActiveSheet.Paste With ActiveSheet Set sp = .Shapes(.Shapes.Count) End With Const spnm = "Picture 1" Set rng = Application.InputBox(Prompt:="シェイプを入れるセルを選択して下さい", Type:=8) If Not rng Is Nothing Then If Not flg Then '←このflgの意味はわからないので残しておきました If Not rng.Parent Is ActiveSheet Then sp.Copy Application.Goto rng ActiveSheet.Paste sp.Delete '元の図形を削除 With ActiveSheet Set sp = .Shapes(.Shapes.Count) End With End If With sp .LockAspectRatio = msoFalse .Left = rng.Left .Top = rng.Top .Width = rng.Width .Height = rng.Height .Fill.Visible = msoFalse .Line.Weight = 0.5 .ZOrder msoSendToBack End With Set rng = Nothing End If End If End Sub 試してみてください。直前の投稿は、非常にわかりやすく記述された投稿だと思います。 (新規ブックで簡単に再現できるコードの提示、エラー箇所とエラー内容の記述）が、投稿されたコードが本来どのような動作をするプログラムなのか? つまり、仕様になる記述もコードの提示と並んで記述しなければなりませんよ!! ichinose ---- 張り付きました。ichinoseさんありがとうございます。（どら） Parentの説明大変すみません。仕様の記述ですが、やりたいことが曖昧ですが、概略を書くべきですね。複数セルに文字を入力してその位置関係を、オートシェイプにして希望のセルにフィット貼付したいと言う感じなのですが。 オートシェイプを作るところがはっきりしていないのですが、複数セルでのオートシェイプ作成と貼付が確認出来ましたので、今回の物で実現出来ます。大変お世話になります。 ...; https://www.excel.studio-kazu.jp/wiki/kazuwiki/200904/20090417160332.txt - [detail] - similar

PREV NEXT

訪問者：カウンタ