- ベストアンサー
図形のクリアができない。
指定範囲(I9:CW40)から図形(円・四角形)のクリアをするとエラーになってしまいます。御教授願えませんでしようか？(尚四角形はセルの枠線上に貼り付けるようにしてあります。) Sub 図形のクリア() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim myRng As Range Set myRng = Range("I9:CW40") 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 Then(ここで、1004の実行エラーになる。) sp.Delete End If Next Set myRng = Nothing Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
- Rord
- お礼率67% (25/37)
- Visual Basic
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
質問者が選んだベストアンサー
sp.TopLeftCell.Address sp.BottomRightCell.Address ともに Address プロパティ をつけてみるとか？
関連するQ&A
- 図形のクリアで実行時の1004エラーになる
指定範囲(I9:CW40)から図形(円・四角形)のクリアをするとエラーになってしまいます。終了をすればクリアはできるのですが。御教授願えませんでしようか？(尚四角形はセルの枠線上に貼り付けるようにしてあります。) Sub 図形のクリア() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim myRng As Range Dim sp As Variant Set myRng = Range("I9:CW40") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then sp.Delete (ここで実行時1004のエラーになる。) End If Next Set myRng = Nothing Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub
- ベストアンサー
- Visual Basic
- 図形のクリアで入力規則の▼が消える
図形のクリアで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
- やはり図形のクリアで実行時エラー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
- エクセルのオートシェープ削除について
セルＥ９：Ｊ９までに斜めの斜線を引いて、削除するマクロを 初心者なりに作成しました。 斜線作成は以下のような感じです。 Set myRng = Range("E9:J9") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell,sp.BottomRightCell), myRng) Is Nothing Then sp.Delete End If Next Set myRng = Nothing で、フォームのボタンに登録させて罫線作ります。 ついでにリドゥボタン（戻る）も作成してやってみたのですが 以下のような感じで Set myRng = Range("E9:J9") For Each sp In ActiveSheet.Shapes If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then sp.Delete End If Next Set myRng = Nothing ですが、Ｌ９にリスト表示（入力規則のリストを設定）させたら If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then のところで1004エラーがでます。 リストはどうしても使用しなければならないので、どうしたらよいか？ どなたか詳しい方おられましたら、ご指導おねがいします。
- ベストアンサー
- その他（プログラミング・開発）
- VBAでオートフィルを使って指定する文字列を含むものを表示させたい
VBAを使って、セルD1に入力した文字列を検索するマクロを作りたいと思っています。 私は初心者で前に似たようなものを作ってもらって それを加工しようとしたのですが、うまくいきませんでした。 以前は完全に一致するもので表示でしたが、 今回は含むものを表示させたいです。 ワイルドカードは＊をつけるのはわかるのですが、 いろいろやってみましたがダメでした。（単純なことかもしれないですけど） Private Sub Worksheet_Change(ByVal Target As Range) Dim myRng1 As Range Dim myRng2 As Range Set myRng1 = Target.Cells(1) If Application.Intersect(myRng1, Range("D1")) Is Nothing Then Exit Sub Set myRng2 = Range("D1").CurrentRegion With myRng2 If myRng1 = "" Then ActiveSheet.ShowAllData Else .AutoFilter Field:=4, Criteria1:=myRng1.Value End If End With End Sub
- 締切済み
- その他（プログラミング・開発）
- EXCEL2007 VBA グラフサイズ修正バグ？
下記のようなグラフのサイズ調整するVBAプログラムをEXCEL２００７で動かしました。 VBEで実行すると正常に動作します。 シートに図形を設置し、その図形にマクロを登録して実行すると、 グラフが3画面位広がってしまいます。 図形にマクロ登録してグラフ調整を正常に動かすことはできないのでしょうか? ----------------------------------------------------- 'グラフの再調整を行うサブルーチン Sub chartRerange() Dim wb As Workbook Dim strWbName As String Dim myRng1, myRng2, myRng3 As Range Dim myChart As Shape Dim rngTarget As Range '開いているすべてのワークブックを処理対象とする For Each wb In Workbooks strWbName = wb.Name '「月度」が含まれているならば処理 If InStr(strWbName, "月度") <> 0 Then Set myRng1 = wb.Worksheets(2) Set myRng2 = wb.Worksheets(3) For Each myChart In myRng1.Shapes 'グラフならば If (TypeOf myChart.OLEFormat.Object Is ChartObject) Then Select Case myChart.Name Case "chart1" Set rngTarget = Range("B24:AG42") End Select 'グラフを指定したエリアに配置する With myChart .Top = rngTarget.Top .Left = rngTarget.Left .Width = rngTarget.Width .Height = rngTarget.Height End With End If Next End If Next MsgBox "処理完了" Set wb = Nothing Set myRng1 = Nothing Set myRng2 = Nothing Set myChart = Nothing Set rngTarget = Nothing End Sub
- ベストアンサー
- オフィス系ソフト
- 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に詳しい方、アドバイスよろしくお願いいたします。
- ベストアンサー
- その他（プログラミング・開発）
- Ｅｘｃｅｌで特定の図形だけ透明化したい
Ｅｘｃｅｌで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
- ベストアンサー
- Excel（エクセル）
- excel vba 範囲をクリアーして再度表示
お世話になります。 シートに縦方向に売上の数字が並んでいます 必要な売り上げと除外する売上をそれぞれ選択し、 まず除外する売上を消去して 必要な売り上げのみ存在している状況で印刷をかけ。 今度は 必要な売上を消去して 除外する売上のみ存在している状況で印刷をかけたく思います。 消去するのはそれぞれ myRng2.ClearContents myRng1.ClearContentsとコードを記載すると できるのですが 印刷をかけた後で 復活させる方法がわかりません。 どうやって記載したらよろしいのでしょうか？ お力をお貸しください。 Dim myRng1 As Range '必要売上 Dim myRng2 As Range '除外売上 On Error Resume Next Set myRng2 = Application.InputBox("除外売上を選択して下さい", "セル選択", Selection.Address, Type:=8) If myRng2 Is Nothing Then Exit Sub myRng2.ClearContents 印刷の処理。 myRng2を復活の処理・・・ここがわかりません On Error Resume Next Set myRng1 = Application.InputBox("必要売上を選択して下さい", "セル選択", Selection.Address, Type:=8) If myRng1 Is Nothing Then Exit Sub myRng1.ClearContents 印刷の処理 myRng1を復活の処理・・・ここがわかりません
- ベストアンサー
- Excel（エクセル）
- エクセルで複数のブックの一部を抽出する
エクセルで複数のブックの一部をBOOK1に1行ずつコピーしたいんですが、いろいろ探して近いものは見つけたのですが、元になるブックの1部の列をコピーするブックの行にコピー出来ないでしょうか？ merlionXXさんのhttp://oshiete1.goo.ne.jp/qa4969413.htmlこれを参考にして作っているのですが、 課名D16 商品名B20:B39 枚数H20:H39 金額I20:I39 の部分をbook1に1件1行としてコピーしたいのですができますでしょうか？ もとのブックの行数は決まっています。 どうか力を貸してください。よろしくお願いします。 Sub test02() Dim MyFile As String, MyPath As String '変数宣言 Dim x As Long, y As Long Dim wb As Workbook, tb As Workbook Dim ka As String Dim sh1, sh2 Set tb = ThisWorkbook MyPath = tb.Path & "\" '自分のパスを取得 MyFile = Dir(MyPath & "*.xls", vbNormal) 'パス内のエクセルファイル Application.ScreenUpdating = False '画面更新停止 Application.Calculation = xlCalculationManual '自動計算停止 Do While MyFile <> "" 'エクセルファイルがなくなるまで If MyFile <> tb.Name Then '自分以外のファイルを対象 Set wb = Workbooks.Open(MyPath & MyFile) '選択したファイルを開く With ActiveSheet ka = .Range("D16").Value '課名取得 x = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 sh1 = .Range("B20:B" & x).Value '商品名取得 sh2 = .Range("H20:I" & x).Value '数量＆金額取得 End With With tb.Sheets("Sheet1") y = .Range("B" & Rows.Count).End(xlUp).Row '最終行取得 y = IIf(.Range("B" & y) = "", y, y + 1) If x >= 20 Then '納品書B20以下にデータがあれば Set myRng = .Range("A" & y).Resize(x - 19, 1) myRng.Value = ka '課名転記 myRng.Offset(, 1).Value = sh1 '商品名転記 myRng.Offset(, 2).Resize(, 2).Value = sh2 '数量＆金額転記 End If End With wb.Close (False) '選択したファイルを閉じる End If MyFile = Dir() '次のファイルを検索 Loop '繰り返し Application.Calculation = xlCalculationAutomatic '自動計算停止解除 Application.ScreenUpdating = True '画面更新停止解除 Set tb = Nothing Set wb = Nothing Set myRng = Nothing End Sub
- ベストアンサー
- その他MS Office製品
お礼
その後何度もやっていて正常に動作するようになりました。ご享受ありがとうございました。 尚、お礼の返事が遅れてすいません。
補足
試しましたが駄目でした。前はできましたが、SkyDriveで編集をやっていてこうなってしまいました。 (尚Ofiiceの再セットアップでも改善されませんでした。) 質問したコード文をコピペしても図形のクリアができません。