• 締切済み

全シート選択するには?

マクロ初心者で申し訳ありません。 シート1の画像を残して削除するマクロなんですが、 シート1しか対応してませんので、これを全シートにするには どうしたらよいか教えてください。 ちなみにシートは 1ページ、2ページ~10ページまであります。 Dim myShap As Shape With Sheet1.GroupObjects Do Until .Count=0 .Ungroup Loop End With For Each myShap In ActiveSheet.Shapes If myShap.Type <> msoPicture Then myShap.Delete End If Next

みんなの回答

noname#62235
noname#62235
回答No.2

#1です。 質問文中のマクロはあなたが考案したものではないのですか? あなたの書いたマクロは、Sheet1に対して処理を行うもの。 私の示したのは、全シートに対して同じ処理を行う汎用的な方法。 だから、Sheet1を「シート」に置き換えて、For Each ~ Nextで全体を囲ってやればいいだけ。 あなたの作ったマクロの後半部分でも、同じようなロジックが使われています。 Dim myShap As Shape Dim シート As Worksheet For Each シート In Worksheets With シート.GroupObjects Do Until .Count=0 .Ungroup Loop End With For Each myShap In シート.Shapes If myShap.Type <> msoPicture Then myShap.Delete End If Next Next 動かしてないので動くかどうかわかりませんが。

takajin831
質問者

お礼

回答についてはありがたく思います。 前任者が辞めたため、バックアップのエクセルを入れた。 前任者はどうも、1シートごと保存していたようで、 私はめんどくさがりやなので、いっぺんにと思い書き込みました。

全文を見る
すると、全ての回答が全文表示されます。
noname#62235
noname#62235
回答No.1

dim シート as worksheet for each シート in worksheets # シートに対して処理を行う next

takajin831
質問者

お礼

初心者なんで もう少し分かりやすくお願いします。

全文を見る
すると、全ての回答が全文表示されます。

関連するQ&A

  • エクセルVBAでオートシェープを識別して削除したいのです・・・

    エクセルシートにたくさん貼り付けた画像を一度に削除するため、下記のようなマクロを作成しました。 しかし、これでは「テキストボックス」や「→」のようなオートシェープも全部消えてしまいます。 画像データ(図)だけを認識して消すにはどうすればよいのでしょうか? Sub sakujo() Dim Myshape As Shape For Each Myshape In ActiveSheet.Shapes If Myshape.Type <> msoFormControl Then Myshape.Delete End If Next End Sub

  • VBAについて教えてください。

    VBAについて質問です。 シート1(元払)があり、そのシート内のオートシェイプを消す式が下記の式で 可能なのですが、別シートのオートシェイプも同時に消す場合はどのようにすれば良いか 教えてください。   Sheets("元払").Select Dim sh As Shape For Each sh In ActiveSheet.Shapes If sh.Type = msoAutoShape Then sh.Delete End If Next sh

  • シート上のjpg画像のみを一括削除したい

    Excel VBA勉強中の者です。 早速ですが、シート上にあるjpg画像のみを一括削除したく ネットで調べつつ以下のコードを作ってみました Sub dlt() '既存の画像を削除 Dim jpgdlt As Shape With ActiveSheet .DrawingObjects.Delete 'このコードが違っている??? For Each jpgdlt In .Shapes ’For Each Next で選択対象を繰り返し削除 jpgdlt.Delete Next End With End Sub これでjpg画像の削除は出来たのですが、シート上に配置した コントロールなどのオブジェクトも全て削除されてしまい困っております。 以下のコードも作ってみたのですが、こちらはメモリーが不足しているという エラーを回避できず、オブジェクトが削除されるか検証する前に使用を断念しました。 Sub dlt() '既存の画像を削除 Dim jpgdlt As Object Set jpgdlt = ActiveSheet jpgdlt.Shapes.SelectAll Selection.Delete End Sub jpg画像のみを選択し、削除するにはどうすれば宜しいのでしょうか? 色々調べてはみたものの、自力での解決に至らず、 お手数お掛けしますがどなたかご助力お願い致します。

  • マクロを使って結合セルに丸を付ける+αな難題。。

    エクセルのマクロについて エクセルでセルや結合セルに丸を付ける質問はどれも見ましたが私にとって難題なものがありましたので、教えて下さい。  結合セルをマクロを使用して丸を付けるものがありますが、どなたか教えては頂けないでしょうか。初心者です、すいません。 1、ダブルクリックで結合セルに文字上に丸(太さ0.75)がつく。 2、ダブルクリックでそのセルから丸が消える。 同じ操作で1,2が繰り返される。 さらにここでもう一つ。 同シート内の※別の場所の結合セルに【データ】の【入力規制】で(リスト)を選択し、リスト内に【■,○,空白,】等の内容を含んでいます。 この上の二つがどちらもちゃんと使える方法が分かりません。 教えては頂けないでしょうか。 ちなみに参考までにマクロはこれを使っています。 正しいマクロを教えて下さい。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim Shp As Shape Cancel = True If ActiveSheet.Shapes.Count <> 0 Then For Each Shp In ActiveSheet.Shapes If Target.Address = Shp.TopLeftCell.Address Then Select Case Shp.Line.DashStyle Case 1: Shp.Delete: Exit Sub Case 4: Shp.Delete: Exit Sub End Select End If Next End If With ActiveSheet.Shapes.AddShape(msoShapeOval, Target.Left, Target.Top, Target.Width, Target.Height) .Fill.Visible = msoFalse .Line.Weight = 0.75 End With End Sub これと入力規制を使おうとしたら、マクロがデバックになってしまい使用できません。 入力規制は残ったままですが、マクロが使えなくなってしまいました。 解決策、何か違うところ、教えて下さい。

  • 選択したシートでマクロを実行させるには

    エクセルでシートが多数あるブックで、選択状態にあるシートのみ、ページ設定の拡大縮小印刷を70%に設定したいのですが。 Dim ws As Worksheet For Each ws In ActiveWindow.SelectedSheets   With ActiveSheet.PageSetup     .Zoom = 70   End With Next ws 例えば、シート4とシート5とシート6を選択状態にして上記のマクロを実行すると、シート4しか拡大縮小印刷の変更処理が行われません。 マクロの間違いを教えて下さい。

  • Excel マクロ cstr を使ったcountができない

    初心者です。すいません質問させて下さい。 Excelのシート上に、オートシェイプを"card"& CStr(Num)として、 連番を付けています。連番の上限は200までにしてあります。 例えば"card1"で名前ボックスに入力すると検索できる一個目の"card1"のオートシェイプが検索されます。 またコピーペーストすると、同じ"card1"になります。 ここで、シート上のそのオートシェイプが何個あるか数えたいのですが、連番の数では判定できないので、マクロで考えてみましたが、うまくいきません。 Sub testcc() Dim Num As Integer, Crd As Integer, Sum As Integer Sum = 0 Num = 1 Do Crd = ActiveSheet.Shapes("card" & CStr(Num)).Count Sum = Sum + Crd Num = Num + 1 Loop Until Num = 200 Range("A1").Value = Sum End Sub 必ず、 Crd = ActiveSheet.Shapes("card" & CStr(Num)).Count でデバックの画面に移ってしまいます。 どう記述が間違っているのかが知りたいです。 御教授お願い致します!

  • 特定の文字を含むシートを選択するには

    いつもお世話になっております。 特定の文字を含むシートのデータをコピーするにはどのようにしたらよろしいでしょうか。 具体的には (1)シート名の末尾に"D"を含むシートを選択 (2)選択したシートのデータをコピー (3)コピーしたデータを順次"Sheet1"に貼付 というマクロを組みたいのですが、(1)のところがうまくいきません。 以下のように作成してみました。 Dim sh As Worksheet Dim lr As Long, tlr As Long For Each sh In Worksheets If sh.Name = "*D" Then lr = sh.Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row sh.Rows("3:" & lr).Copy tlr = Sheets("Sheet1").Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row Sheets("Sheet1").Range("A" & tlr + 1).PasteSpecial End If Next 4行目の sh.Name = "*D" のところがうまくないようです。 よろしくお願いします。

  • 範囲内の同名オブジェクトの削除

    任意の範囲にあるオートシェイプを削除しようとして、調べて見たところ下記のような例文がありました。 Dim Obj As Object Dim MyR As Range, CkR As Range Dim M_Range As Range For Each Obj In ActiveSheet.DrawingObjects Set MyR = Range(Obj.TopLeftCell, Obj.BottomRightCell) Set CkR = Intersect(MyR, Range("B25:CN27")) If Not CkR Is Nothing Then If CkR.Count = MyR.Count Then Obj.Delete End If Set CkR = Nothing End If Set MyR = Nothing Next これだと通常に貼り付けたシェイプは削除出来るのですが、やろうとしているシートにはグループ化したシェイプを複数コピーして貼り付けてあります。 その為だと思うのですが、上記の方法だと削除出来ません。 原因は名前が同じなのでObj.Deleteが実行できないのだと思います。 同名のオブジェクトがある場合削除する方法はあるのでしょうか? 実行したいのはシートの一部の範囲内だけです。 宜しくお願い致します。 尚、マクロの記録で行うと以下の様な状態です。 ActiveSheet.Shapes.Range(Array("グループ化 16", "グループ化 16", ・・・・)).Select Selection.Delete

  • オートシェープをグルーピングして動作させたい

    office365 2つのオートシェープをグルーピングして図形を動作させたい 下記で kibanは平行四辺形のオートシェープ yajirushiは右向き矢印のオートシェープ で、それぞれ、ある範囲で左から右に移動を繰り返します。 この2つのオートシェープをグルーピングして 平行四辺形の右側に矢印を配置した状態で、そのグルーピングされた図形の動作を繰り返す様にしたいのですが、 その内容が分からないのでコードで教えていただきたく、よろしくお願いします。 #If Win64 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) #Else ' Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) #End If Sub kiban() shape_delete Dim ws2 As Worksheet Dim i As Integer Set ws2 = Sheets("sheet1") ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 354, 46, 20).Select With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(0, 176, 80) .Transparency = 0 .Solid End With ws2.Shapes.AddShape(msoShapeParallelogram, 2265, 458, 20, 20).Select ws2.Shapes(ws2.Shapes.Count).name = "kiban" For i = 0 To 30 If i = 30 Then i = 0 End If ws2.Shapes(1).Left = i * 3 + 365 ws2.Shapes(1).Top = 458 Sleep 100 DoEvents Next i ws2.Shapes("kiban").delete End Sub Sub yajirushi() shape_delete Dim ws As Worksheet Dim i As Integer Set ws = Sheets("sheet1") ws.Shapes.AddShape msoShapeRightArrow, 2265, 458, 20, 20 ws.Shapes(ws.Shapes.Count).name = "yajirushi" For i = 0 To 30 If i = 30 Then i = 0 End If ws.Shapes(1).Left = i * 3 + 420 ws.Shapes(1).Top = 458 Sleep 100 DoEvents Next i ws.Shapes("yajirushi").delete End Sub Sub shape_delete() Dim shp As Shape Dim rng As Range Range("P22:CM28").Select If TypeName(Selection) <> "Range" Then Exit Sub For Each shp In ActiveSheet.Shapes '‘ 図形の配置されているセル範囲をオブジェクト変数にセット Set rng = Range(shp.TopLeftCell, shp.BottomRightCell) '‘ 図形の配置されているセル範囲と '‘ 選択されているセル範囲が重なっているときに図形を削除 If Not (Intersect(rng, Selection) Is Nothing) Then shp.delete End If Next End Sub

  • エクセル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.を打ち込んでいたら、 「コンパイルエラー:プロシージャが大きすぎます」とエラーが出てしまいました。 ループさせればよいのだろうと試してみたのですが、元のセルの指定方法や、オートシェイプの出現させるせるの指定方法がわかりません。 どのようにすれば、データー元の範囲を指定して、それに対応したセルにオートシェイプを出現させる事が出来るようになるでしょうか。 お知恵を貸していただけないでしょうか。よろしくお願い致します。