Excelで特定の図形だけ透明化する方法はあるか
- ExcelでSheet上に表示されている図形を透明化するマクロを実行すると、複数の図形がすべて透明化されてしまう。特定の図形だけを透明化する方法はあるのか。
- ExcelのSheet上に表示されている図形を透明化するマクロを実行すると、全ての図形が透明化される。特定の図形だけを透明化する方法はあるのか。
- ExcelでSheet上に表示されている複数の図形を透明化するマクロを実行すると、すべての図形が透明化されてしまう。特定の図形だけを透明化する方法はあるのか。
- ベストアンサー
Ｅｘｃｅｌで特定の図形だけ透明化したい
ＥｘｃｅｌでSheet上に図形を表示し、下記マクロを実行すると徐々に透明化しますが、 複数の図形を表示し実行するとすべてが透明化されます。特定の図形だけを透明化する方法ありますか For N = 1 To 200 Dim sh As Shape Dim tr As Double For Each sh In ActiveSheet.Shapes tr = sh.Fill.Transparency tr = tr + 0.0061 If 1 <= tr Then tr = 1 sh.Fill.Transparency = tr Next Range("a1").Select Next End Sub
- perogou
- お礼率78% (516/655)
- Excel（エクセル）
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
透過する図形をどのように特定するのかわまりませんので、ご提示されたマクロ記述をベースに、選択されている図形(複数可)のみを透過するようにしてみました。 Sub Test() Dim sh As Shape, tr As Double, N As Long With Selection For N = 1 To 200 tr = .ShapeRange.Fill.Transparency tr = tr + 0.0061 If 1 <= tr Then tr = 1 .ShapeRange.Fill.Transparency = tr DoEvents Next End With Range("a1").Select End Sub
関連するQ&A
- [ EXCEL VBA ] 図形を読み込む順番を制御するには？
お世話になります。 ワークシート上にある全ての図形を読み込む際、下記の場合だと、図形を配置した順番に読み込まれます。 Dim sh as Shape For Each sh in ActiveSheet.Shapes ・・・（省略） Next sh これを、例えば左上に配置しているものから順に読み込む、といったようなことを、EXCEL VBAで実現できるでしょうか？ EXCELは2003です。 よろしくお願いいたします。
- ベストアンサー
- Visual Basic
- EXCEL VBAで自在に図形を変化させたい。
今回の質問は図形に寸法値を入れるために基礎学習として簡単なマクロを作った件についてです。 シート上のコマンドボタンでフォームを呼び出し、文字の位置（100とか）を入力し、数字等文字を打ち込むと 打ち込んだ文字がその位置に表示されるというものです。 Private Sub Cmd文字表示_Click() Dim x As Single, y As Single, Sh As Shape On Error Resume Next x = CSng(Text位置A.Value) y = CSng(TextBox1.Value) With ActiveSheet For Each Sh In .Shapes If Sh.Name <> "Cmd文字入力" Then Sh.Delete End If Next Sh .Shapes.AddTextbox(msoTextOrientationHorizontal, x, x, _ x, x).Select End With With Selection.ShapeRange .Fill.Visible = msoFalse .Fill.Transparency = 0# .Line.Weight = 0.75 .Line.DashStyle = msoLineSolid .Line.Style = msoLineSingle .Line.Transparency = 0# .Line.Visible = msoFalse End With Selection.Characters.Text = "y" With Selection.Characters(Start:=1, Length:=3).Font .Name = "ＭＳ Ｐゴシック" .FontStyle = "標準" .Size = 11 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With End Sub 文字位置を自由に変えることは出来ますが打ち込んだ文字に変化させることが出来ません。 簡略的なコードや文字を表示させるには別の方法があるという方がいましたらご教示お願いします。
- ベストアンサー
- Visual Basic
- やはり図形のクリアで実行時エラー1004
図形を二行三列で一枡とし図形を貼り付けていますが、どうしても実行時エラー 「1004」が出て図形のクリアができません。(尚、四角形は枠線上にあります。) 対処法がありましたらお願いします。 Windows7・SP1 Office2010 Sub 図形の貼付け() Dim i As Integer Dim j As Integer For i = 10 To 43 Step 2 For j = 9 To 99 Step 3 Select Case Cells(i, j).Value Case 1: ActiveSheet.Shapes("四角形1").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 2: ActiveSheet.Shapes("四角形2").Select Selection.Copy Cells(i + 1, j).Select ActiveSheet.Paste Case 4: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 1).Select ActiveSheet.Paste Case 5: ActiveSheet.Shapes("四角形3").Select Selection.Copy Cells(i + 1, j + 2).Select ActiveSheet.Paste Case 6: ActiveSheet.Shapes("円1").Select Selection.Copy Cells(i, j).Select ActiveSheet.Paste End Select Next Next End Select End Sub Sub 図形のクリア() Dim myRng As Range Set myRng = Range("I10:CW43") Dim n As Integer, sp As Variant For n = ActiveSheet.Shapes.Count To 1 Step -1 Set sp = ActiveSheet.Shapes(n) If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing (ここで実行時エラー1004になります。) Then sp.Delete End If Next Set myRng = Nothing End Sub
- ベストアンサー
- Visual Basic
- ＶＢＡについて教えてください。
ＶＢＡについて質問です。 シート1（元払）があり、そのシート内のオートシェイプを消す式が下記の式で 可能なのですが、別シートのオートシェイプも同時に消す場合はどのようにすれば良いか 教えてください。 Sheets("元払").Select Dim sh As Shape For Each sh In ActiveSheet.Shapes If sh.Type = msoAutoShape Then sh.Delete End If Next sh
- ベストアンサー
- Visual Basic
- 半透明の図形を指定したい
Win7 Excel2010を使用しています。 沢山の四角があるので、マクロを作ってみましたが、うまくいきません。 お知恵を貸していただきたいと思います。 エクセルのシート状に沢山の□(四角)があり ます。 それぞ れに色々な色が付いていて、半透明になっているものもあります。（50％や60％） 試行錯誤して、なんとか下記のようなマクロで四角は消せたのですが、 一緒に半透明の四角も消されてしまいます。 四角のみ消して、半透明の四角は残したいのです。 半透明 の四角を、消さない方法はどうすればいいのでしょうか？ 一応作ってみたマクロを下記に書きました。 Sub 四角を選択しグループ化後削除() Dim sh As Shape For Each sh In ActiveSheet.Shapes If sh.Fill.ForeColor.RGB = RGB(255, 153, 0) Then '薄いオ レンジ sh.Select False End If If sh.Fill.ForeColor.RGB = RGB(192, 192, 192) Then '25%灰色 sh.Select False End If Next Selection.ShapeRange.Group.Select Selection.Delete End Sub よろしくお願いします。
- 締切済み
- その他MS Office製品
- 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
- ベストアンサー
- オフィス系ソフト
- 図形のクリアで入力規則の▼が消える
図形のクリアでG1の入力規則の▼まで一時的に消えてしまいます。コード文でShapesを 用いているのではないかと思いますが、▼で消去を回避する方法が ありましたらお教え願え ますでしょうか？ Windows7・SP1 Office2010 Sub 図形のクリア() Dim myRng As Range Dim sp As Variant Set myRng = Range("I10:CW60") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then On Error Resume Next sp.Delete End If Next Set myRng = Nothing End Sub
- ベストアンサー
- Visual Basic
- エクセルVBAの記述方法の質問です。
エクセルです。12個のセルの文字列をオートシェープの吹き出しに順に表示させるマクロをつくりました。 Sub tenki2() Dim i As Integer Dim a As String For i = 1 To 12 a = Cells(i, 2).Value ActiveSheet.Shapes("AutoShape 4").Select Selection.Characters.Text = a Application.Wait Now + TimeValue("00:00:05") Next i End Sub これで思った通り表示されるのですが、できればオートシェープをセレクトしないようにしたいのです。 （シートを保護するため） それで ActiveSheet.Shapes("AutoShape 4").Select Selection.Characters.Text = a のところを ActiveSheet.Shapes("AutoShape 4").Characters.Text = a と変えたのですが、「オブジェクトはこのプロパティまたはメソッドをサポートしていません」という実行時エラーがでてしまいました。書き方のどこがまずかったのでしょうか？ご教示いただければ幸いです。
- ベストアンサー
- オフィス系ソフト
- スライド内のオブジェクトを消すマクロ
PowerPointのVBAマクロで、スライド中にspaceという文字列のみのテキストボックス以外のオブジェクトを消すマクロを以下のように作成したのですが、このマクロを実行しても、いくつかのオブジェクトが残ってしまいます。 Sub foo() Dim f As Boolean Dim sl As Slide Dim sh As Shape For Each sl In ActivePresentation.Slides For Each sh In sl.Shapes If sh.HasTextFrame Then If sh.TextFrame.TextRange.Text <> "space" Then sh.Delete End If End If Next Next End Sub コレクションをFor eachで回しているので、漏れはないはずなのですが、どなたか原因・対策をご教示いただけないでしょうか？
- ベストアンサー
- Visual Basic
- Excel VBAでの図形削除について質問です。
Excel VBAでの図形削除について質問です。 ボタンをクリックすると、ラインを使って、直角三角形を作成できる様にしました。 その際に、画像を全て削除してから作成する様にしました。 しかし、コマンドボタンまで消えてしまい困っています。 Dim MyLine As Shape Dim rngStart As Range, rngEnd As Range Dim BX As Double, BY As Double, EX As Double, EY As Double Dim dellShape As Object Set dellShape = ActiveSheet dellShape.Shapes.SelectAll 'すべての図形を選択する Selection.Delete '現在選択されているオブジェクトを削除する 'Shapeを配置するための基準となるセル Set rngStart = Range("C30") Set rngEnd = Range("J11") 'セルのLeft、Top、Widthプロパティーを利用して位置決め BX = rngStart.Left BY = rngStart.Top EX = BX + 300 EY = BY + 0 'Shapeの描画 Set MyLine = ActiveSheet.Shapes.AddLine(BX, BY, EX, EY) '横幅 Set MyLine = ActiveSheet.Shapes.AddLine(EX, EY, EX, 200) '高さ Set MyLine = ActiveSheet.Shapes.AddLine(BX, BY, EX, 200) '斜辺 これで?削除?作図と出来るのですが、作図された図形をDeleteキーで手動で削除した後に、 もう一度コマンドボタンをクリックすると、コマンドボタンまで削除されてしまいます。 通常ではコマンドボタンは削除されないので、原因が解りません。 同じ経験をされた方や、ExcelVBAに詳しい方、アドバイスよろしくお願いいたします。
- ベストアンサー
- その他（プログラミング・開発）
お礼
ありがとうございました。とてもうまくできました。感謝 感謝