• ベストアンサー

Excel VBA 指定シートの有無確認

指定した名前のシートがあるかないか判断させてますが、 以下のやりかたでは、 グラフ作成したシートを認識してくれません。 そのようにすれば良いでしょうか？ Dim ws As Worksheet, flag As Boolean For Each ws In Worksheets If ws.Name = "シート" Then flag = True 　Next ws If flag = True Then 　msgbox "あります 　Else 　Sheets.Add 　ActiveSheet.Name = "シート" End If

  • magm
  • お礼率10% (5/47)

質問者が選んだベストアンサー

  • ベストアンサー
  • nda23
  • ベストアンサー率54% (777/1415)
回答No.1

WorkSheets ではなく Sheets コレクションを使います。 あと、ループじゃなくて、直にやったほうが速いのでは？ Dim Dummy On Error Resume Next Set Dummy = Sheets("シート") '★該当シートを変数に代入 If Err.Number = vbNormal Then flag = True On Error GoTo 0 If flag Then == 以下、略 "シート"というシートがあれば、Set命令は正常終了します。 Errオブジェクトを調べて、Numberプロパティが0なら正常、非0なら異常です。 サンプルでは０の代わりに予約シンボルのvbNormalを使いました。

magm
質問者

お礼

WorkSheetsがだめだったんですね。 うまくできました。 早々のご教授ありがとうございました。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • 指定シートの有無を確認

    指定したシートの有無を確認するVBAを作っているのですがうまく作動しません。 Sub dummy() Dim dummy Dim sheetname As String sheetname = Sheets("入力").Cells(1, 1).Value　'←『入力』というシートのセルA1と同じ値のシート名 On Error Resume Next Set dummy = sheetname If Err.Number = vbnomal Then flag = True On Error GoTo 0 If flag Then Msgbox "シートがあります" Else Sheets("原紙").Copy before:=Sheets(1) Worksheets(1).Name = sheetname End Sub 補足：入力というシートのA1に値が入っており、その値と同じシートがあればメッセージが出る、無ければ『原紙』というシートをコピーしてコピーしたシートのタブにA1の値を表示する

  • ＥＸＣＥＬマクロ　シートのありなし

    EXCELのマクロでシートの存在を返す関数を作っています。 一応動くのですが、ブックをいちいちアクティブにしているのが 気に入りません。スマートな手法を教えて頂けませんか。 よろしくお願いします。 例） 　A.xls、B.xls、C.xls、D.xlsのように複数のブックが開かれています。 　マクロは、マクロ.xlsというファイルに記述しているとします。 　例えば、A.xlsというファイルにsheet4という名前のシートが存在するか調べたい。 Function isExistingSheetName2(Bookname As String, sheetname As String) As Boolean Dim wb As Workbook Dim ws As Worksheet Dim flag As Boolean Dim wbown As Workbook Dim wsown As Worksheet '現在を記憶 Set wbown = ThisWorkbook Set wsown = ActiveSheet '判定 Set wb = Workbooks(Bookname) wb.Activate　　　　　　　　　　　　　　　　　　’←特に気に食わない 　　For Each ws In Worksheets If ws.Name = sheetname Then flag = True Next ws '元に戻る wbown.Activate　　　　　　　　　　　　　　　　’←気に食わない　　　 wsown.Select　　　　　　　　　　　　　　　　　’←若干気に食わない 　　'戻り値 If flag = True Then isExistingSheetName2 = True Else isExistingSheetName2 = False End If End Function ’excel　2002　SP3 ’windowsXP　Pro　SP3

  • VBA シート名重複した場合削除する

    教えてください。 VBAに関しての質問です。 全くの知識がないので教えていただきたいです。 エクセルワークシートに以下の機能を追加している状態です。 For Each ws In Worksheets If ws.Name = "データ" Then wsChkflg = True End If Next If wsChkflg = True Then ThisWorkbook.Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "データ" Else ThisWorkbook.Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = "データ" End If Set wsNew = ThisWorkbook.Worksheets("データ") 「データ」というシートが作成、追加されるのですが、同じシート名で新規作成した時に エラーが出てしまいます。そのエラーを出さないようにすため、ダイアログ等も出さずに既存のシートを強制的に削除する機能を追加したいのです。 VBAの知識がなくて困っています。 何か良い方法がわかる方いらっしゃいましたらお力を貸してください。 よろしくお願いいたします。

  • VBA（エクセル）で教えて下さい。開いていないBOOKの貼り付け

    VBA（エクセル）で教えて下さい。開いていないBOOKのシートを開いているBOOKのシートに貼り付けで、開いているBOOKから開いていないBOOK名を指定したいのですが、 現在開いているエクセルです。 SHEETS(Type)のRANGE（A1）に閉じているBOOK名を入力します。 SHEETS（In）に閉じているBOOKのSHEETSを貼り付けたいのですが、 Ex = Sheets("Type").Range("A1")　　が無いと閉じているEx.xlsを貼り付けます。 このExと言うBOOK以外も多々コピーしたいのですが、どのように書けば良いか分からず、 是非、教えて下さい。 Sub a1() Dim wsSrc As Worksheet, WS As Worksheet Dim PasteR As Range Dim x As Long Sheets("In").Select Cells.Select Selection.Delete Shift:=xlUp Range("A1").Select 'If Worksheets(1).Name = "STEP1" Then ' Worksheets(1).Activate ' Cells.ClearContents ' Else 'Worksheets.Add(Before:=Worksheets(1)).Name = "一覧" 'End If 　　Ex = Sheets("Type").Range("A1") 　　Set wsSrc = ActiveSheet Workbooks.Open "C:\WINDOWS\デスクトップ\test\Ex.xls" For Each WS In Worksheets x = WS.Range("A1").CurrentRegion.Rows.Count If WS.Index = 1 Then Set PasteR = wsSrc.Range("A1") Else Set PasteR = wsSrc.Range("A65536").End(xlUp).Offset(1) End If WS.Range(WS.Cells(1, 1), WS.Cells(x, 44)).Copy PasteR Set PasteR = Nothing Next ActiveWorkbook.Close False Set wsSrc = Nothing End Sub

  • エクセルVBAで困っています。

    　エクセルでSheet1でSheet2に各銀行の出納帳を作りそこから各項目ごとに別Sheetに振り分けたいと思っています。 　ある方にエクセルVBAで作って頂いたのですが、最初作って頂いた時の項目は会費、会議費、事務費の３つでした。その項目を９つに増やしたいと思っています。又、全てのSheetで１行目には銀行名や項目名を入れたいので２行目から日付、内容・・・といったように入力したいです。そうした場合、どこをどう変更したらよいのか分かりません。自分がわかる範囲で（適当ですが）挑んでみたのですが、私自体VBAについて全く無知のため何が何だかサッパリです。どなたか教えて頂くことはできないでしょうか。ちなみに文字数に制限があったため改行やスペースなどは入れていません。見難いとは思いますがよろしくお願いします。どうか皆様のお知恵を貸して頂けると幸いです。 Option Explicit Sub Teller() '【考え方】Sheet1とSheet2を入力と考える。 'マクロを実行したときに、Sheet1,2を元に、項目別に振り分ける。 Const BankName1 As String = "○銀行" Const BankName2 As String = "(チェック)銀行" Const tempSheet As String = "一時シート" Dim classify(9) As String Dim title(5) As String Dim i As Long Dim j As Long Dim lastRow1 As Long Dim lastRow2 As Long Dim findUpper As Long Dim findLower As Long Dim keyword As String Dim ws As Worksheet Dim Bank1 As Worksheet Dim Bank2 As Worksheet Dim Temp As Worksheet Set Bank1 = Worksheets(BankName1) Set Bank2 = Worksheets(BankName2) '【振り分ける項目名】 classify(1) = "会費" classify(2) = "会議費" classify(3) = "事務費" classify(4) = "事業費" classify(5) = "研修費" classify(6) = "報償費" classify(7) = "慶弔費" classify(8) = "予備費" classify(9) = "積立金" '【1行目に記載する見出し】 title(1) = "日付" title(2) = "内容" title(3) = "収入" title(4) = "支出" title(5) = "残高" '画面更新を停止 Application.ScreenUpdating = False '最終行取得 Bank1.Select lastRow1 = Cells(Rows.Count, 1).End(xlUp).Row Bank2.Select lastRow2 = Cells(Rows.Count, 1).End(xlUp).Row 'シートを作る For i = 1 To 3 Call MakeNewSheet_As_ThisName(classify(i)) For j = 1 To 5 Cells(1, j) = title(j) Next j Next i Call MakeNewSheet_As_ThisName(tempSheet) Cells.ClearContents Set Temp = Worksheets(tempSheet) '一時シートに、銀行1のデータと銀行2のデータをコピーする。 Bank1.Select Bank1.Range(Cells(3, 1), Cells(lastRow1, 5)).Copy Temp.Select Temp.Range(Cells(1, 1), Cells(lastRow1 - 2, 5)).PasteSpecial Bank2.Select Range(Cells(3, 1), Cells(lastRow2, 5)).Copy Temp.Select Cells(lastRow1 - 1, 1).PasteSpecial 'ソートする。 '第一優先キー：B列。[項目]昇順。 '第二優先キー：A列。[日付]昇順。 Range("A1:E" & (lastRow1 + lastRow2 - 4)).Select With ActiveWorkbook.Worksheets(tempSheet).Sort .SortFields.Clear .SortFields.Add Key:=Range("B1:B" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第一キー .SortFields.Add Key:=Range("A1:A" & (lastRow1 + lastRow2 - 4)), Order:=xlAscending '第二キー .SetRange Range("A1:E" & (lastRow1 + lastRow2 - 4)) .Apply End With For i = 1 To 3 keyword = classify(i) findUpper = 0 findLower = 0 '上から探す For j = 1 To lastRow1 + lastRow2 - 4 Step 1 If Cells(j, 2) = keyword Then findUpper = j Exit For End If Next j If findUpper > 0 Then '下から探す For j = lastRow1 + lastRow2 - 4 To 1 Step -1 If Cells(j, 2) = keyword Then findLower = j Exit For End If Next j 'コピー Range(Cells(findUpper, 1), Cells(findLower, 5)).Copy Sheets(keyword).Select Range("A2").Select ActiveSheet.Paste Range("B2:B" & 2 + (findLower - findUpper)).Delete Shift:=xlToLeft Sheets(tempSheet).Select End If Next i '一時シートの削除 Application.DisplayAlerts = False Temp.Delete Application.DisplayAlerts = True 'アクティブセルをA1にしておく For Each ws In Worksheets Sheets(ws.Name).Select 'シート選択 Application.CutCopyMode = False Range("A1").Select Next ws Bank1.Select '画面更新を行う Application.ScreenUpdating = True MsgBox "実行しました" End Sub Sub MakeNewSheet_As_ThisName(ByVal GivenName As String) 'シートの有無を確認し、無ければ作る Dim exist_flag As Boolean Dim ws As Worksheet exist_flag = False For Each ws In Worksheets If UCase(ws.Name) = UCase(GivenName) Then 'シートが存在する場合 exist_flag = True Exit For End If Next ws 'シートを作成 If GivenName = "" Then MsgBox "空白名のシートは作れません。" ElseIf exist_flag = False Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GivenName End If Sheets(GivenName).Select 'シート選択 End Sub

  • エクセルVBA　シート名の部分一致検索について　エクセル2007

    VBAでエクセルの全シート名を部分一致で検索したいと考えています。 そこで以下のコードを書いたのですが、 インプットボックスにどんな文字列を入力しても全てのシート名を 取得してしまって途方にくれています。 どなたかお助けください。 Sub test01() Dim name As String Dim ws As Worksheet shn = InputBox("検索文字列を入力") For Each ws In ThisWorkbook.Worksheets If ws.Name Like " * " & name & " * " Then ws.Activate MsgBox ws.Name End If Next ws End Sub

  • 【Excel VBA】ワークシートの表示(続き)

    すみません。 追記が出来なかったため、コードの続きをこちらに記載します。 For i = 1 To 12 If actsht = tmp(i) Then Flag = 1 Anser = MsgBox("翌月分シートを作成しますか？", vbYesNo + vbDefaultButton1, "確認") If Anser = vbYes Then ActiveSheet.Copy After:=ActiveSheet ActiveSheet.Name = tmp(i + 1) Sheets(actsht).Tab.ColorIndex = 2 Sheets(actsht).Range("B3").Value = Sheets("Sheet2").Range("A1").Value Sheets(actsht).Range("B4").Value = Sheets("Sheet2").Range("A2").Value ActiveSheet.Range("A2").Select Exit For ElseIf Anser = vbNo Then Exit For End If End If Next If Flag = O Then MsgBox ("新しいワークシートを作成出来ません。") End If If actsht = tmp(i) Then If Sheets(元データ).Visible = False Then Sheets(元データ).Visible = True End If End If End Sub

  • エクセルのマクロについて教えていただきたいのですが・・・

    見積書を作成しているんですが、1枚目のシート（見積書）に明細が書ききれなかった時に、マクロを実行すると、『明細書』と言う名前のシートが(1)～(5)枚目まで追加され、各シートの小計を1枚目のシートに書き出す・・・と言うマクロを作りたいのですが、うまくいかずに困っています＞＜ 追加されるシートの元となる『見積もりマスター』と言うシートがあって、そのシート内でそれぞれのシートの小計は取れるのですが・・・ 下記のマクロの中に何か追加すればうまくいく方法はありますか？？ （明細書は追加する時もあれば追加しない時もあってその都度、使う人が、最大5枚まで何枚追加するかを決めるそうです。） Sub Macro1() Dim cnt As Integer Dim wkNum As Double Dim ws As Worksheet 　For Each ws In Worksheets 　　If Left(ws.Name, 4) = "明細書(" Then 　　　If IsNumeric(Mid(ws.Name, 5, 1)) Then 　　　　wkNum = Val(Mid(ws.Name, 5, 1)) 　　　　If cnt < wkNum Then 　　　　　cnt = wkNum 　　　　End If 　　　End If 　　End If 　Next ws 　If cnt >= 5 Then 　　MsgBox ("明細書シートが既に５枚以上あるため追加できません") 　　Exit Sub 　Else 　　Sheets("明細マスター").Copy after:=Sheets(Worksheets.Count) 　　ActiveSheet.Name = "明細書(" & cnt + 1 & ")" 　End If End Sub マクロ自体をあまり理解できてなくて、会社の人や、ここで教えていただいて進めているので、出来ればそのままコピーして使用できるようにしていただけるとありがたいです。 よろしくお願いします。

  • End Ifは不要な場合もある？

    Excel2010使用で下記のVBAのコードを書きました。 Sub イフとエンドイフは組ではなかったのか() 　Dim Flag As Boolean 　Dim S As Worksheet 　　For Each S In Worksheets 　　　If S.Name = "合計" Then Flag = True ' 　　Else ' 　　　Flag = False ' 　　End If 　　Next S 　　If Flag = True Then 　　　MsgBox "「合計」というシートはすでに存在します" 　　Else 　　　Worksheets(1).Copy after:=Worksheets(Worksheets.Count) 　　　ActiveSheet.Name = "合計" 　　End If End Sub 前半の >' Else >' Flag = False >' End If の部分があると「Elseに対応するIfがありません」というエラーが出ます。 Elseに関する記述だけをコメントアウトすると「End Ifに対応するIfブロックがありません」というエラーが出ます。 この部分をコメントアウトすればきちんと動作するのですが、If文はちゃんと存在しているにもかかわらず、またほとんど同じ記述の後半ではエラーが出ないというのに、なぜこのようなエラーが出るのかわかりません。 なにか勘違いをしているのでしょうか。

  • Excel VBA で特定のシートのみ除外

    ＶＢＡで以下のような、ブック内の全シートから特定の文字列が入った行のみを新しくシート作成して一覧化するマクロを組みました。 検索する時に保護解除するなど別の作業もあるため無駄に長くなっております。 Sub 検索() Dim Sh As Worksheet, Rng As Range Dim StrFind As String, Res As String Dim Rw As Long, R As Long Dim N As Integer Const OutShName = "検索結果" StrFind = InputBox("検索する文字列を入力してください。" & " 　　 検索する文字列は正確に。", "検索文字列") If StrFind = vbNullString Then Exit Sub Dim Ws As Worksheet Application.ScreenUpdating = False For Each Ws In Worksheets Ws.Unprotect Password:=908118 Next Application.ScreenUpdating = True Application.ScreenUpdating = False UserForm1.Show vbModeless UserForm1.Repaint For N = 1 To Worksheets.Count If Worksheets(N).Name = OutShName Then Set Sh = Worksheets(N) Sh.Move after:=Worksheets(Worksheets.Count) Sh.Cells.ClearContents Exit For End If Next N If N > Worksheets.Count Then Set Sh = Sheets.Add(after:=Worksheets(Worksheets.Count)) Sh.Name = OutShName End If Worksheets(1).Rows(1).Copy Sh.Rows(1) R = 2 For N = 1 To Worksheets.Count - 1 With Worksheets(N).UsedRange For Rw = 1 To .Rows.Count Set Rng = .Cells(Rw, 1).Resize(, .Columns.Count).Find(StrFind) If Not Rng Is Nothing Then Rng.EntireRow.Copy Sh.Rows(R) R = R + 1 End If Next Rw End With Next N Unload UserForm1 ResultMsg: If R < 3 Then Res = "「" & StrFind & "」 は、見つかりません。" For Each Ws In Worksheets Ws.Protect Password:=908118 Next Sheets("TOP").Select Else Columns("A:A").ColumnWidth = 20 Columns("C:C").ColumnWidth = 13 Rows("1:1").RowHeight = 30 Sheets("12月").Select Rows("1:1").Select Selection.Copy Sheets("検索").Select Range("A1").Select Application.ScreenUpdating = True Res = "「" & StrFind & "」 は、" & R - 2 & " 件 見つかりました。 " & _ String(2, vbLf) & Sh.Name & " に抽出しました。" Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Selection.Font.Bold = False Selection.Font.Bold = True End If MsgBox Res, vbInformation, "検索完了" Set Rng = Nothing End Sub Excel2003を使用してます。 シートは30枚程あり、複雑な計算式等が入っています。 この時、特定のシート（例:"月別データ")のみを除外したいのですが、いまいちわかっておりません。 稚拙な質問かと思いますがご指導していただきたく思います。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する