• 締切済み

既存のエクセルマクロに命令文を追加

既存のマクロに別の命令文を追加する場合について質問です。 選択した範囲のオブジェクトを削除するマクロがあります。 下の命令文に 「シート2でも同じことをする（ただし選択範囲はC30からG33）」 を追加する場合には、どのように書けばいいのでしょうか？ Sheets("シート1").Select Range("A65:E365").Select Dim shp As Shape Dim rng_shp As Range 'セルが選択されていないときは終了 If TypeName(Selection) <> "Range" Then Exit Sub 'アクティブシートのすべての図形にループ処理 For Each shp In ActiveSheet.Shapes '図形の配置されているセル範囲をオブジェクト変数にセット Set rng_shp = Range(shp.TopLeftCell, shp.BottomRightCell) '図形の配置されているセル範囲と '選択されているセル範囲が重なっていれば図形を削除 If Not Intersect(rng_shp, Selection) Is Nothing Then shp.Delete End If Next Sheets("シート0").Select Range("A1").Select 同じものを上記命令文の下にコピーして選択シートと範囲を直すだけだと、 Dim shp As ShapeとDim rng_shp As Rangeがエラーになります。 どなたかご教示お願いします。

みんなの回答

  • stomachman
  • ベストアンサー率57% (1014/1775)
回答No.1

コピーの中から、エラーになった2行だけを取り除けば良いです。 これらは変数shpとmg_shpについての宣言文であり、初めて変数を使うところより前に一度だけ書くものなので、「重複して書いてある」という理由でエラーになったんです。

  1. カテゴリ
  2. ビジネス・キャリア
  3. その他（ビジネス・キャリア）

関連するQ&A

  • EXCEL2000で作成したマクロが2007で動作しない

    EXCEL2000で作成したマクロがEXCEL2007上で動作しません。 2つのシートに入ったデータを，「抽出」シートにコピー後， 抽出条件に合わせて抽出するというものなのですが， 「Sheet1」で最終行を取得するところで，正しい範囲を 選択しません。どこが間違えているのか，ご指南頂けないでしょうか? お願いいたします。 下には，正しい結果が出ない所までを貼りつけました。 Sub フィルタオプション() Dim LastRow As Long, LastColumn As Long Dim myData As Range Dim myCriteria As Range Sheets("Sheet1").Select Rows("1:1").Select Selection.Copy Sheets("抽出").Select Rows("3:3").Select ActiveSheet.Paste If Worksheets("Sheet1").FilterMode = True Then 　　Worksheets("Sheet1").ShowAllData End If With Worksheets("Sheet1") LastRow = .Cells(Application.Rows.Count, "A").End(xlUp).Row End With Sheets("Sheet1").Select Range(Rows(2), Rows(LastRow)).Select Selection.Copy Range("A1").Select Sheets("抽出").Select Range(Rows(4), Rows(4)).Select Selection.Insert Shift:=xlDown

  • エクセル　マクロ：文字変更

    教えてください。 sheet5にデータがあります。 マクロを実行すると、一番右の列のセルに○があると●と書き換える 一番右の列のセルに△があると▲と書き換えるコードを作成しています。 下記のコードでは時間がかかってしまいます。 省略 If Sheets("sheet5").Cells(r, cmax).Value = "○" Then Sheets("sheet5").Cells(r, cmax).Value = "●" 省略 AutoFilterを使用してマクロを作成しましたが、列に○と△が両方無いと 範囲指定したセルがすべて▲となってしまいます。 下記コードをどのように手直ししたらよいのか教えて頂けないでしょうか。 よろしくお願いします。 Sub 文字変更() Dim c As Integer Dim cmax As Integer Dim rmax As Long With Sheets("sheet5") rmax = .Range("A3").End(xlDown).Row cmax = .Range("A3").End(xlToRight).Column .Rows("1:1").Select Selection.AutoFilter For c = 2 To cmax Selection.AutoFilter Field:=c, Criteria1:="○" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "●" Selection.AutoFilter Field:=c, Criteria1:="△" .Cells(1, c).Offset(1, 0).Select .Range(Selection, Cells(rmax, c)).Value = "▲" Selection.AutoFilter Field:=c Next c End With Selection.AutoFilter End Sub

  • Excelマクロについて

    先日、OKWEBで教えてもらったマクロに手を加えて作ろうとしたのですが、エラーがでて動かなくなりました。 わかる方がいましたら教えてください。 よろしくおねがいします。 Sub 見積書() Application.ScreenUpdating = False '見積書(完成)シートを選択 Sheets("見積書(完成)").Select '行の高さを「15」にする。 Rows("6:67").Select Range("F6").Activate Selection.RowHeight = 15 'S列のS6:S56をコピーしてE6:E7に貼り付ける。 Range("S6:S56").Select Selection.Copy Range("E6:E7").Select ActiveSheet.Paste '5列目(工数)が「0」のとき該当する行の高さを「0」にする。 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 If Cells(i, 5).Value = "0" And Cells(i, 7).Value = "0" Then Rows(i).RowHeight = 0 End If Next '「E8:E55」の範囲を四捨五入する。 For i = ActiveSheet.UsedRange.Rows.Count To 1 Step -1 Range("E8:E55") = Application.Round(Range("E8:E55"), 0) '工数を四捨五入 Next 'C列の中に含まれる「小計」を検索しそこから6列目が「0」だったら行の高さを「0」にする。 Dim Rng As Range Const Retu = "C" For Each Rng In Range(Retu & "1", Range(Retu & "100").End(xlUp)) If Trim(Rng.Value) = "小　　　計" And _ Rng.Offset(, 6) = 0 Then Rng.EntireRow.Hidden = True End If Next Rng End Sub

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

    office365 ２つのオートシェープをグルーピングして図形を動作させたい 下記で kibanは平行四辺形のオートシェープ yajirushiは右向き矢印のオートシェープ で、それぞれ、ある範囲で左から右に移動を繰り返します。 この２つのオートシェープをグルーピングして 平行四辺形の右側に矢印を配置した状態で、そのグルーピングされた図形の動作を繰り返す様にしたいのですが、 その内容が分からないのでコードで教えていただきたく、よろしくお願いします。 #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

  • エクセルマクロについて助言下さい。

    エクセルマクロについて助言下さい。 ★やりたい事 シート名を指定しアクティブにする BOOOKに複数のセルがあり、シート名は日付（1・2など） 但し、必ず連続ではなく1~31までのシートが存在します。 現在のマクロ↓ シート名を取得し関数で指定のシートが存在するか確認しています。 作業シートのC1セルが0で指定シートなし　0でないで指定シートあり（処理開始）としてます。 作業2のI3セルに日付データがあります。 Sub 抽出() 'シート名を取得する Sheets("作業").Select Dim i As Integer Dim mySheetCnt As Integer Dim mySheetNam As String 　　 mySheetCnt = ThisWorkbook.Sheets.Count For i = 1 To mySheetCnt mySheetNam = Sheets(i).Name Sheets("作業").Cells(i, 1) = mySheetNam Next i　　 Range("A1").Select If ActiveCell.Value = "" Then 'A1が空白の場合の処理 MsgBox "指定の日付のシートが存在しません" Exit Sub End If Sheets("作業").Select Range("C1").Select If ActiveCell.Value = 0 Then 'C1が0の場合の処理 MsgBox "指定の日付のシートが存在しません" Exit Sub End If Sheets("作業2").Select Range("I3").Select Sheets(ActiveCell.alue).Select End Sub このコードだと3と指定すると左から３枚目にあるシートが選択されます。 ３枚目ではなくシート名が　３　を選択したいのです。。 分かりにく説明で申し訳ありませんが、教えてください。

  • Excelマクロ　○印図形を消したい

    ○印図形を消したい Private Sub CommandButton2_Click() ' ○印をつける Dim a As Range If TypeName(Selection) = "Range" Then Set a = Selection ActiveSheet.Shapes.AddShape(msoShapeOval, a.Left, _ a.Top, a.Width, a.Height).Select Selection.ShapeRange.Fill.Visible = msoFalse a.Select End If End Sub Private Sub CommandButton3_Click() 上記のマクロでつけた○印を下記のようなマクロで（指定の範囲のセルにつけた○印を全て）消したいのですが、上記のマクロは問題なく動作するのですが、下記のマクロがうまく動きません、どこをどのように変更したらよいのでしょうか？、どなたかご教示ください。 ' 指定したセル範囲にある図形を削除する() ' ○印の削除 指定セル範囲 = "U32:X41" With ActiveSheet Set セル範囲 = .Range(指定セル範囲) For Each 図形 In .Shapes If 図形.Type = msomsoPicture Then Set 共有セル範囲 = Intersect(Range(図形.TopLeftCell, _ 図形.BottomRightCell), セル範囲) If Not (共有セル範囲 Is Nothing) Then 図形.Delete End If End If Next End With End Sub

  • Excel VBAを使った重複行の抜き出しについて教えてください

    以下のような2シートから、重複する「商品番号」のあるsheet1の行を抜き出して、別シートに書き出したいと思っております。 sheet1 　｜　　A　　 ｜　 B　　　｜　C -＋--------＋-------＋----- 1｜　　　 　　｜　　　　　　｜ -＋--------＋------＋-------- 2｜商品番号｜商品名｜責任者 -＋--------＋------＋-------- 3｜　 123456｜　 ガム｜山田太郎 -＋--------＋------＋-------- 4｜ 2345678｜　チョコ｜田中花子 ・・・ sheet2 　｜　　A　　 ｜　 B　　　｜　C -＋--------＋-------＋----- 1｜　　　　　　｜　　　　　｜ -＋--------＋------＋-------- 2｜商品番号｜商品名｜責任者 -＋--------＋------＋-------- 3｜ 3987624｜　　　　　｜ -＋--------＋------＋-------- 4｜ 193678｜　　　　　　｜ ・・・ そこでVBAを作成したのですが、例えば商品番号「222011001」の行を抜き出したいのに、「22011001」の行も一緒に抜き出してしまいます。 どこがいけないのか、教えて頂けないでしょうか。 作成したVBAは以下の通りです。 VBA初心者で本を見ながら作ったため、大変見にくくなっているかと思います。申し訳ありませんが、どなたかおわかりになる方がいらっしゃいましたら、どうぞ宜しくお願い致します。 Option Base 1 Option Explicit Sub 重複データ抽出書き直し() Dim シート(2) As Worksheet Dim 比較列(2) As Integer Dim 一致セル As Range Dim 検索範囲 As Range Dim i As Integer Set シート(1) = Sheets("sheet1") Set シート(2) = Sheets("sheet2") 比較列(1) = 1: 比較列(2) = 1 シート(2).Activate ActiveCell.CurrentRegion.Select Selection.Offset(1, 比較列(2) - 1) _ .Resize(Selection.Rows.Count - 1, 1) _ .Select Set 検索範囲 = Selection Sheets.Add After:=Sheets(Sheets.Count) シート(1).Activate ActiveCell.CurrentRegion.Select Selection.Resize(1).Copy With Sheets(Sheets.Count).Range("A1") If Application.Version >= 9 Then .PasteSpecial 8 End If .PasteSpecial End With For i = 2 To Selection.Rows.Count Set 一致セル = 検索範囲.Find(Selection.Cells(i, 比較列(1)).Value) If Not 一致セル Is Nothing Then Selection.Offset(i - 1).Resize(1) _ .Copy Sheets(Sheets.Count) _ .Range("A65536").End(xlUp) _ .Offset(1) End If Next i Sheets(Sheets.Count).Activate End Sub

  • エクセルマクロの分割方法について

    Sub リスト登録() ' ' Macro3 Macro ' マクロ記録日 : 2008/6/2 ' ActiveSheet.Unprotect Password:="1234" If Range("G33").Value > 5 Then Sheets("リスト").Select ActiveSheet.Shapes("AutoShape 44").Select Selection.Copy Sheets("シート").Select Range("A15").Select ActiveSheet.Paste End If Dim Btn As Integer Dim strMsg As String strMsg = "リストに登録しますか？" Btn = MsgBox(strMsg, vbYesNo + vbQuestion, "MsgBox") If Btn = vbNo Then Dim YU As Shape For Each YU In ActiveSheet.Shapes If YU.Type = msoAutoShape Then YU.Delete End If Next If Btn = vbYes Then End If ActiveSheet.Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True Range("C11").Select End End If Dim newRange1 As Range, newRange2 As Range, newRange3 As Range Select Case Sheets("").Range("B3").Value Case 1 Set newRange1 = Sheets("リスト").Range("I6") Set newRange2 = Sheets("リスト").Range("AH6") Set newRange3 = Sheets("リスト").Range("AI6") 中略 Case 1000 Set newRange1 = Sheets("リスト").Range("I1005") Set newRange2 = Sheets("リスト").Range("AH1005") Set newRange3 = Sheets("リスト").Range("AI1005") ActiveWorkbook.Save Case Else End Select Application.ScreenUpdating = False Sheets("シート").Range("G8,G10,G12:G23,G25:G29,G31:G32").Copy newRange1.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=True newRange1.UnMerge Sheets("シート").Range("D34").Copy newRange2.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Sheets("シート").Range("I29").Copy newRange3.PasteSpecial Paste:=xlPasteValues, _ Operation:=xlNone, SkipBlanks:=False, Transpose:=False Sheets("シート").Select Range("C11").Select Range("D34,G8:G32,I29").Select Selection.ClearContents Range("C11").Select Dim SP As Shape For Each SP In ActiveSheet.Shapes If SP.Type = msoAutoShape Then SP.Delete Range("D34:K34").Select Application.CutCopyMode = False Selection.Merge Range("B3").Select End If Next ActiveSheet.Protect Password:="1234", DrawingObjects:=True, Contents:=True, Scenarios:=True End Sub 上記のマクロを作成しましたが、６４Ｋを超えてしまう為、分割したいのですが、どのように分割すればよいのか方法がわかりません、どなたかお分かりの方がいらっしゃいましたら宜しくお願いします。 マクロシート１～２～３といったつなぎの構文がわかりません宜しくお願い致します。

  • エクセルマクロ：範囲の選択

    マクロで範囲を指定したいのですが、 dataと名づけたシートA1に例えば8という値、A2に20という値があります。 この数字は他のセルから参照する計算式になっていて再計算をするたびに変わります。 この時、C8:E20の範囲を指定したいのですが、やみくもに Dim c As Integer c = 3 'C列 Range(Cells(Sheets("data").Range("A1").Value, c), Cells(Sheets("data").Range("A2").Value, c + 2)).Select Selection.Copy などと書いてみたのですが、うまくいきません。 どのように記述すればよいか、教えてください、宜しくお願いいたします。

  • エクセル２００７マクロ　シート間のセルコピー

    [Sheet1]にあるデータを[Sheet2]にコピーするマクロボタンを[Sheet2]に作りたいのですが、マクロがよく分からないので、「マクロの記録」で作成してみました。 Sub siken() ' ' siken Macro ' ' Sheets("Sheet1").Select Range("A1").Select Selection.Copy Sheets("Sheet2").Select Range("A1").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("B3").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("B3").Select ActiveSheet.Paste Sheets("Sheet1").Select Range("B6:D6").Select Application.CutCopyMode = False Selection.Copy Sheets("Sheet2").Select Range("B6").Select ActiveSheet.Paste End Sub （実際はもっと多くのセルをコピーします） マクロを実行すると、ちゃんとコピーできるのですが、セルをコピーする都度[Sheet1]と[Sheet2]が交互に表示されます。 コピー元の[Sheet1]を表示させずにマクロを実行させるにはどのようにしたらよいのでしょうか？ よろしくお願いします。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する