- ベストアンサー
エクセル、ワークシートが保護されているかどうかを判断するVBAは？
- みんなの回答 （4）
- 専門家の回答
質問者が選んだベストアンサー
If Worksheets(i).ProtectContents Then に変えればイケます。 頑張ってくださいヽ(^。^)ノ
その他の回答 (3)
- imogasi
- ベストアンサー率27% (4737/17068)
＃２です。＃３が入りましたが If ws.ProtectContents Then のIf ws.ProtectContents＝True Then のTrueを略しました。よくこう言う例が載ってますので使いました。 IF分のIf Thenの中に限ります。 Falseを聞くときは、書いておられるとおりでOK、略せません。
お礼
なんどもありがとうございました。
- snoopy64
- ベストアンサー率42% (337/793)
＃１です。 はい、それで間違ってないです！ 「Worksheets(i).Protect」はプロテクトをかけるメソッドで、成功するとTrueを返します（たぶん）。 「Worksheets(i).ProtectContents」はプロテクトが掛かっているかどうかの状態をTrueかFalseで返します。 蛇足ですが、「ProtectContents」自身がBoolean（TrueかFalse）なので、 If Not Worksheets(i).ProtectContents Then とも書けます。 頑張ってくださいヽ(^。^)ノ
お礼
なんどもありがとうございました。
- imogasi
- ベストアンサー率27% (4737/17068)
Sub test05() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.ProtectContents Then MsgBox ws.Name End If Next End Sub
お礼
ワークシートが保護されていないことをチェックしたかったので下記のようにしました。間違ってないですよね？ ありがとうございました。 Sub test05() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets If ws.ProtectContents = False Then MsgBox ws.Name End If Next End Sub
関連するQ&A
- Excel VBAで検索（Win2000 Excel2000）
現在、下記のようなコードを書いています。データテーブルの縦と横の検索値を探してその列数と行数を返したいのですが、下記の Sub検索1 と Sub検索2 を1つのSubで実行させるにはどうしたらよいのでしょうか？よろしくお願い致します。 ----------------------------------------- Sub 検索1() Worksheets("Data").Activate Dim x As Integer For x = 3 To 22 If Cells(2, x).Value >= 12 Then MsgBox x Exit Sub End If Next MsgBox "見つかりません" End Sub --------------------------------------------- Sub 検索2() Worksheets("Data").Activate Dim i As Integer For i = 4 To 42 If Cells(i, 2).Value = "A" Then MsgBox i Exit Sub End If Next MsgBox "見つかりません" End Sub
- ベストアンサー
- オフィス系ソフト
- エクセルVBAでSheet1.ActivateとSheet(n).Activate
エクセル2000です。 VBAでの疑問点を教えてください。 Sub test1() Sheet1.Activate MsgBox ActiveSheet.Name End Sub これは問題なく作動します。 Sub test2() x = ThisWorkbook.Worksheets.Count For n = 1 To x Sheet(n).Activate MsgBox ActiveSheet.Name Next End Sub これは「SubまたはFunctionがていぎされていません」というエラーになります。 もちろん、 Sub test3() x = ThisWorkbook.Worksheets.Count For n = 1 To x Sheets(n).Activate MsgBox ActiveSheet.Name Next End Sub のように書けばOKなのは存じておりますが、これではSheet名に係らず、左から順番となってしまいます。 Sub test4() x = ThisWorkbook.Worksheets.Count For n = 1 To x Sheets("Sheet" & n).Activate MsgBox ActiveSheet.Name Next End Sub のように明確にシート名として記述すればOKなのですが、それでは、Test1のSheet1.Activate が通って、Sheet(n).Activate が通らないのはなぜでしょう？ しょうもない質問でごめんさない。
- ベストアンサー
- オフィス系ソフト
- 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枚程あり、複雑な計算式等が入っています。 この時、特定のシート（例:"月別データ")のみを除外したいのですが、いまいちわかっておりません。 稚拙な質問かと思いますがご指導していただきたく思います。
- 締切済み
- その他MS Office製品
- ExcelのVBAのエラーについて
以下のVBAだとファイルの選択画面が出てきて、キャンセルを押して選択をやめると「ファイルが選択されませんでした」と出て、実行時のエラー1004が出てしまいます。 どうにかエラーを出さない方法を考えているのですが、何がだめなのかが分かりません。色々試しましたが上手くいかなくて非常に困っています。VBA初心者ですがよろしくお願いいたします。 Sub 実装図読み込み1_Click() Dim vriFileName As Variant vriFileName = Application.GetOpenFilename( _ FileFilter:="MIcrosoft Excelブック,*.xls,", _ Title:="実装図のファイルを選択", _ MultiSelect:=False) If vriFileName = Falese Then MsgBox "ファイルが選択されませんでした。", _ vbOKOnly + vbExcelamation, "ファイル名の入力チェック" End If Set targetBook = Workbooks.Open(vriFileName) Dim myCnt As Integer Dim myArray myCnt = Worksheets.Count If myCnt >= 1 Then ReDim myArray(myCnt - 1) For i = 1 To myCnt myArray(i - 1) = Worksheets(i).Name Next i Sheets(myArray).Copy After:=ThisWorkbook.Sheets(1) End If targetBook.Close False Application.ScreenUpdating = True Set targetBook = Nothing Set newWorksheet = Nothing End Sub
- ベストアンサー
- その他（プログラミング・開発）
- ブック内に特定名のシートがある場合
はじめまして、こんにちは。 ＶＢＡを最近はじめたばかりの者です。質問が初歩的なもので申し訳ないのですが是非教えてください。 以下を使って、複数ブックの○○というシートから指定セルの内容を抜き出したいと思っています。 ところが、ブックによっては○○というシートが存在しない場合があり、その場合には「インデックスが有効でない」というエラーで動作が止まってしまいます。 ブック内に○○というシートがある場合にのみ動作させるようにするにはどのようにすれば良いのでしょうか。 よろしくお願いします。 Dim wb As Workbook, myRow As Long Dim e As Integer myRow = ThisWorkbook.Worksheets(1).Rows.Count With Application.FileSearch .NewSearch .LookIn = ThisWorkbook.Path .SearchSubFolders = True .FileType = msoFileTypeExcelWorkbooks If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If .FoundFiles(i) <> ThisWorkbook.FullName Then Set wb = Workbooks.Open(.FoundFiles(i), UpdateLinks:=0) Application.ScreenUpdating = False ThisWorkbook.Worksheets(1).Range("A" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F6").Value ThisWorkbook.Worksheets(1).Range("B" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F7").Value ThisWorkbook.Worksheets(1).Range("C" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("F8").Value ThisWorkbook.Worksheets(1).Range("D" & myRow).End(xlUp).Offset(1, 0).Value = _ wb.Worksheets("○○").Range("Y6").Value wb.Close False End If Next i Else MsgBox "ファイルがありません。" End If End With End Sub
- ベストアンサー
- Visual Basic
- 全くの初心者ですVBA
どこが悪いかわかりません。 教えてください。 Sub テスト() Dim kekka As String Dim i As Integer tokuten = Worksheets("Sheet1").Cells(i, 1).Value For i = 1 To Worksheets("Sheet1").Range("A1").End(xlDown).Row.Count If tokuten >= 80 Then kekka = "合格" Else kekka = "不合格" kekka = Cells(i, 2) End If Next i End Sub シート１の A列に数値で得点が入っています。
- ベストアンサー
- その他（プログラミング・開発）
- シート番号追加VBA
watabe007さま 大変お世話になりました 前にシートのセルにページ番号を追加するVBAをこちらで教えて頂きまして、本当に有難うございます 前回に下記の内容を教えて頂き、大変有難く使わせていただいております Sub pageA() Dim i As Long For i = 1 To Worksheets.Count If Worksheets(i).Name = "Sheet3" Then Worksheets(i).Range("G2") = "'" & i & "/" & Worksheets.Count ElseIf Worksheets(i).Name = "Sheet4" Then Worksheets(i).Range("G3") = "'" & i & "/" & Worksheets.Count Else Worksheets(i).Range("G1") = "'" & i & "/" & Worksheets.Count End If Next End Sub それで、今回はどのシート名にも属さないシートはページカウントとしてカウントしない、という方法がありましたらお教え頂きたいのですが、方法はありますでしょうか？ お忙しいかと思いますが、アドバイス頂けますますと嬉しいです
- ベストアンサー
- Excel（エクセル）
- VBAにて複数フォルダのエクセルファイルからデータ抽出を行いたいのですが…
現在、下記の方法で複数のブックからデータを抽出し、 一覧表示をしています。（一覧表示をしているブックを仮にＡとします。） 今のままだと、同一フォルダ内のブックしか抽出されません。 これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか？ 簡単に例をあげると、 フォルダ（1）の中にＡを入れておいて フォルダ（1）の下にあるサブフォルダ（1）、サブフォルダ（2）の中にあるブックからデータの抽出を行いたいのです。 現在つかっているVBAは Sub 抽出用() Dim FName As String Dim Folder As String Dim wb As Workbook Dim i As Integer, j As Integer Application.ScreenUpdating = False Folder = ThisWorkbook.Path & "\" i = 1: j = 1 Worksheets(1).Cells.ClearContents FName = Dir(Folder & "*.xls") Do While FName <> "" If FName <> ThisWorkbook.Name Then Workbooks.Open (Folder & FName) Workbooks(Workbooks.Count).Worksheets(5).Rows("1:1").Copy _ ThisWorkbook.Worksheets(5).Cells(i + 3, 1) Workbooks(Workbooks.Count).Close Application.StatusBar = j & "ファイル処理済み" i = i + 1: j = j + 1 End If FName = Dir() Loop Application.StatusBar = "" Application.ScreenUpdating = True MsgBox ("完了しました") End Sub です。 いいお知恵があれば、よろしくお願い致します。
- ベストアンサー
- オフィス系ソフト
- VBAでシートの保護
初めまして。 私はWindowsXP、Excel2003のVBAでシートの保護、またそれの解除のコードを組んだのですが、以下のコードでは「○○○と言う名前で保存します。よろしければこのままOKをクリックしてください」の箇所でキャンセルを選択した時に、シートの保護を行いたいのですが、どのようなコードにすればよいてのでしょうか？ 例） Dim FileName As String Dim FileExt As String Dim BkName1 As String Dim BkName2 As String Dim BkName3 As String Dim OldWkbook As Workbook Dim NewWkbook As Workbook Const StName1 As String = "適材適所グラフ" Const StName2 As String = "適材適所回答" Const StName3 As String = "適性検査III回答" Const StName4 As String = "適性検査IIIグラフ" 'シートの保護を解除 Worksheets("適性検査III回答").Unprotect Worksheets("適材適所回答").Unprotect Application.DisplayAlerts = False Set OldWkbook = ActiveWorkbook ' 'ファイル名を取得 BkName1 = OldWkbook.Sheets(StName3).Range("L1").Value BkName2 = OldWkbook.Sheets(StName3).Range("L2").Value BkName3 = OldWkbook.Sheets(StName3).Range("L3").Value FileName = BkName1 & Format(".") & BkName2 & Format(".") & BkName3 & ".xls" ' FileName = InputBox(FileName & "と言う名前で保存します" & vbCr & "よろしければこのままOKをクリックしてください", "保存ファイル名の確認", FileName) If FileName = "" Then Exit Sub Else If Right(FileName, 4) <> ".xls" Then MsgBox "ファイル名が異常です。" Exit Sub End If End If OldWkbook.Sheets(Array(StName1, StName2, StName3, StName4)).Copy Set NewWkbook = ActiveWorkbook 'ボタンを削除 For wIx = NewWkbook.Sheets(1).Shapes.Count To 1 Step -1 If Left(NewWkbook.Sheets(1).Shapes(wIx).Name, 6) = "Button" Then 'ボタンのみ削除 NewWkbook.Sheets(1).Shapes(wIx).Delete End If Next NewWkbook.Sheets(1).Name = StName1 'コピー先シートの保護 Sheets(1).Protect Sheets(2).Protect Sheets(3).Protect Sheets(4).Protect FileName = "C:\採点結果\" & FileName If Dir(FileName) <> "" Then '##ファイルが既に存在する If MsgBox("既に指定のファイルが存在します。 置き換えますか?", vbOKCancel, "置き換えの確認") = vbCancel Then NewWkbook.Close savechanges:=False '##保存せずに終了 Exit Sub '##指定ファイル置き換え保存 End If NewWkbook.SaveAs FileName:=FileName Else '##ファイルを新規保存 NewWkbook.SaveAs FileName:=FileName End If NewWkbook.Close savechanges:=False Application.DisplayAlerts = True 'シートの保護 Worksheets("適性検査III回答").Protect Worksheets("適材適所回答").Protect End Sub
- ベストアンサー
- Visual Basic
- リストボックスから選択したシートを削除したい
Excel2007でマクロ作成の初心者です。 リストボックスの選択項目のワークシートを削除したいのですが、 「インデックスが有効範囲にありません。」のエラーが発生し、 先に進めません。どうしたらよろしいでしょうか？ ’--------------------- Private Sub 顧客削除_Click() Application.ScreenUpdating = False Unload Me Unload DS請求フォーム Dim i As Integer With 顧客リスト For i = 0 To .ListCount - 1 If .Selected(i) Then ' Worksheets(.list(.ListIndex)).Delete Worksheets(Split(.list(.ListIndex - 0), " ")(1)).Activate '←ここでエラー発生 ActiveSheet.Delete End If Next i End With MsgBox "選択の顧客を削除しました。" End Sub ’------------------------- Private Sub UserForm_Initialize() Workbooks("請求.xls").Activate Dim i As Integer Const EXCEPT_NAME = "経理●一覧●基本●" For i = 1 To Worksheets.Count If InStr(EXCEPT_NAME, Worksheets(i).Name & "●") = 0 Then 顧客リスト.AddItem i & " " & Worksheets(i).Name End If Next i End Sub ’----------------------
- ベストアンサー
- Visual Basic
お礼
ワークシートが保護されていないことをチェックしたかったので下記のようにしました。間違ってないですよね？ ありがとうございました。 Sub TEST2() Dim n As Integer n = ThisWorkbook.Worksheets.Count For i = 1 To n If Worksheets(i).ProtectContents = False Then MsgBox Worksheets(i).Name End If Next End Sub