• ベストアンサー

マクロ　シートの保護

下記のマクロにおいて、A列以外のセルに文字なり数字なりを書くと、シートの保護が解除されてしまいます。 また、保護が解除されている状態でA列に20091010と入力してマクロを実行させるとシートが保護されます。 ずーっと保護された状態を続けるようにするにはどのようにすればよいですか？ Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim r As Range Dim flg As Long flg = 0 If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect flg = 1 End If If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub 'A列のみを対象　最初につなげるところ For Each r In Target Dim a As Long Dim b As String With r If Not .NumberFormatLocal = "ge.m.d" Or .Value = "" Then .NumberFormatLocal = "G/標準" 'セルの書式設定がH00.m.d形式だったら標準に戻す 'セルが　数字　　　　且　　　　　　整数　　　　且　　101以上　　且　　　　991231以下　の場合 If IsNumeric(.Value) And Int(.Value) = .Value And .Value >= 19010101 And .Value <= 20991231 Then b = Left(.Value, 4) & "/" & Mid(.Value, 5, 2) & "/" & Right(.Value, 2) If IsDate(b) Then 'もしbがDateの形なら .Value = CDate(b) 'データ型を日付にする 'ここにつなげる。　変数はtmpからbに直す .NumberFormatLocal = "ggg" & _ IIf(Format(b, "e") > 9, "e年", "_0e年") & _ IIf(Month(b) > 9, "m月", "_1m月") & _ IIf(Day(b) > 9, "d日", "_1d日") If ActiveSheet.UnprotectContents = True Then ActiveSheet.Protect flg = 1 End If End If End If End With Next If flg = 1 Then ActiveSheet.Protect End Sub

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

  • ベストアンサー
  • hige_082
  • ベストアンサー率50% (379/747)
回答No.3

最後までコードを見てませんが If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub を flg = 0 If ActiveSheet.ProtectContents = True Then の間へ移動 でうまく行きませんか？

その他の回答 (3)

  • kmetu
  • ベストアンサー率41% (562/1346)
回答No.4

> 最初と最後どちらもけすんですか？ 最初と最後って…一箇所しかないと思いますが… > 通常はシートを保護してます。が、A列に記入の際シートの保護を解除してなければマクロが正常に動作しません。 と、最初の質問にあった > ずーっと保護された状態を続けるようにするにはどのようにすればよいですか？ という話は矛盾してます。 > A列以外でセルの変化があると、シートの保護が解除される状況です。 A列が変更されたかどうかを判断するのは Target.Column = 1 かどうかを調べればいいです。 そもそもA列にデータを入力したいのなら A列をロックしていなければいいのではないですか

  • kmetu
  • ベストアンサー率41% (562/1346)
回答No.2

If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect flg = 1 End If の部分を削除するかコメントアウトしてください

motty7777
質問者

補足

最初と最後どちらもけすんですか？ 通常はシートを保護してます。が、A列に記入の際シートの保護を解除してなければマクロが正常に動作しません。 で、If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect flg = 1 を付け足したのですが、A列以外でセルの変化があると、シートの保護が解除される状況です。

  • zap35
  • ベストアンサー率44% (1383/3079)
回答No.1

詳しく見ていませんがＡ列のセルが変更されたときに処理を行っているようですから Private Sub Worksheet_Change(ByVal Target As Range) 　If Intersect(Target, Range("A:A")) Is Nothing Then 　　Exit Sub 　Else 　　ActiveSheet.Unprotect 　　　For Each r in Target 　　　　ここに処理を書く 　　　Next r 　　ActiveSheet.Protect 　End If ではいけませんか？ なお質問文の処理ではTargetのなかに１つでも条件に合致するセルがあれば　ActiveSheet.Protect　してしまうので、条件に合致する２つ目以降のセルでエラーになる気もしますが、それで問題はありませんか？

motty7777
質問者

補足

＞なお質問文の処理ではTargetのなかに１つでも条件に合致するセルがあれば　ActiveSheet.Protect　してしまうので、条件に合致する２つ目以降のセルでエラーになる気もしますが、それで問題はありませんか？ 間違いないです。zap35さんのやり方もう少しわかりやすくお願いできませんか？初心者です。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • 日付入力マクロ

    On Error Resume Next Dim r As Range Dim flg As Long flg = 0 If Intersect(Target, Range("A4:A600,E4:E600,J4:J600")) Is Nothing Then Exit Sub 'A列のみを対象　最初につなげるところ ActiveSheet.Unprotect flg = 1 For Each r In Target Dim a As Long Dim b As String With r If Not .NumberFormatLocal = "ge.m.d" Or .Value = "" Then .NumberFormatLocal = "G/標準" 'セルの書式設定がH00.m.d形式だったら標準に戻す 'セルが　数字　　　　且　　　　　　整数　　　　且　　101以上　　且　　　　991231以下　の場合 If IsNumeric(.Value) And Int(.Value) = .Value And .Value >= 19010101 And .Value <= 20991231 Then b = Left(.Value, 4) & "/" & Mid(.Value, 5, 2) & "/" & Right(.Value, 2) If IsDate(b) Then 'もしbがDateの形なら .Value = CDate(b) 'データ型を日付にする 'ここにつなげる。　変数はtmpからbに直す .NumberFormatLocal = "ggg" & _ IIf(Format(b, "e") > 9, "e年", "_0e年") & _ IIf(Month(b) > 9, "m月", "_1m月") & _ IIf(Day(b) > 9, "d日", "_1d日") ActiveSheet.Protect End If End If End With Next End Sub 上記のマクロで20090731と入力すると平成21年7月31日と表示されます。 210731を入力して平成21年7月31日と表示されるようにすることは可能ですか？

  • Excel簡単入力

    　　　A　　　　　B　　　　　C　　　　　D 1　　日付　　　部門　　　支店　　　　氏名　　　金額 2　　21/12/1　 製造　　　東京　　　　山田　　　1000 3　　21/12/3 　営業　　　大阪　　　　宮崎　　　 500 上セルと同一内容を簡単に入力する際、Ctrl キー+Shift+"で上セルの内容をコピーし編集状態になりEnterで確定しますよね？それをもっと簡単に空白セルの時Enterで上セルをコピーし編集状態でもう一度Enterで確定というマクロを組みたいので教えてください。初心者です。 なお、皆さんに教えてもらってA1:A600まで以下のマクロを設定し正常に動作しています。 Private Sub Worksheet_Change(ByVal Target As Range) On Error Resume Next Dim r As Range Dim flg As Long flg = 0 If Intersect(Target, Range("A4:A600")) Is Nothing Then Exit Sub 'A列のみを対象　最初につなげるところ ActiveSheet.Unprotect flg = 1 For Each r In Target Dim a As Long Dim b As String With r If Not .NumberFormatLocal = "ge.m.d" Or .Value = "" Then .NumberFormatLocal = "G/標準" 'セルの書式設定がH00.m.d形式だったら標準に戻す 'セルが　数字　　　　且　　　　　　整数　　　　且　　101以上　　且　　　　991231以下　の場合 If IsNumeric(.Value) And Int(.Value) = .Value And .Value >= 101 And .Value <= 1111231 Then b = Str(Val(Left(.Value, 2)) + 1988) & "/" & Mid(.Value, 3, 2) & "/" & Right(.Value, 2) If IsDate(b) Then 'もしbがDateの形なら .Value = CDate(b) 'データ型を日付にする 'ここにつなげる。　変数はtmpからbに直す .NumberFormatLocal = "ggg" & _ IIf(Format(b, "e") > 9, "e年", "_0e年") & _ IIf(Month(b) > 9, "m月", "_1m月") & _ IIf(Day(b) > 9, "d日", "_1d日") ActiveSheet.Protect End If End If End With Next End Sub どうかよろしくお願いします。

  • 行ごとに保護するマクロにパスワードを付けたい

    Excel2010を使用しております。 A列に「承認」という文字が入ると、その行が保護されるマクロがあります。 今の状態ですと、［校閲］-［シート保護の解除］を押すと解除されてしまいますので 保護を解除する際にパスワードを設定したいのですが上手く行きません。 どうかお助け下さい。宜しくお願い致します。 Private Sub Worksheet_Change(ByVal Target As Range) Dim r, rng As Range Set rng = Intersect(Target, Columns(1)) If Not rng Is Nothing Then If ActiveSheet.ProtectContents = True Then ActiveSheet.Unprotect End If For Each r In rng If r.Value = "承認" Then r.EntireRow.Locked = True Else r.EntireRow.Locked = False End If Next r ActiveSheet.Protect DrawingObjects:=True, Contents:=True, AllowFormattingCells:=True End If End Sub

  • セルをダブルクリックするとフィルタリングしてくれるマクロですが意味を理

    セルをダブルクリックするとフィルタリングしてくれるマクロですが意味を理解しようとしましたが理解できません（＞へ＜）どなたか意味を教えてください！ Option Explicit Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim i As Integer For i = 1 To 256 Step 1 If ActiveSheet.Range("a2").Offset(0, i - 1).Value = "" Then Exit For Next If Target.Row > 1 And Target.Column < i Then ActiveSheet.Range("a2").AutoFilter Field:=Target.Column, Criteria1:=Target.Value ActiveSheet.Range("a1").Select Else ActiveSheet.Range("a2").AutoFilter ActiveSheet.Range("a2").AutoFilter ActiveSheet.Range("a1").Select End If End Sub

  • Excel マクロのFor～Nextで再起動エラー

    勤務表を作っています。 下記の’ＯＫまでは希望どうりうまく出来ていたのですが、勤務表の下セルに各列の人員（行）１０名分位Ａ，Ｂ,Cの計を表示させたい。実行するとエラー「Microsoft office Excel　再起動」を求められます。 　for～が判断指令が<重い>のでしょうか。なんとか回避さする方法を教えてください。 Win XP Sp2 Office Excel 2007です。今回これを作るにあたり初ＶＢＡ使用者です。 '　C入力後の翌日は休をセット。CC連続は休休セット。 Private Sub Worksheet_Change(ByVal Target As Range) Dim cnt As Variant Dim a1 As Byte Dim b1 As Byte Dim c1 As Byte Dim nin As Variant Dim retsu As Variant If Target.Count > 1 Then Exit Sub '複数セルの入力は無視 'Ａ If Target.Value = "Ａ" Or Target.Value = "A" Then Target.Value = "A" Range("AV16").Value = Target.Column End If 'Ｂ If Target.Value = "Ｂ" Or Target.Value = "B" Then Target.Value = "B" Range("AV16").Value = Target.Column End If 'Ｃ If Target.Value = "Ｃ" Or Target.Value = "C" Then Range("AV16").Value = Target.Column Target.Value = "C" Else End If ' If Target.Value = "C" Then If Target.Offset(0, -1).Value = "C" Then 'Ｃが連続したら Target.Offset(0, 1).Resize(1, 2).Value = ("休") '連休に Else End If Target.Offset(0, 1).Value = ("休") 　　'そうでなければ休 End If 'A,B,C の数をカウントする。 nin = Range("AV15")　　'別のプログラムから入力した人員数 retsu = Range("AV16")　　' A,B,Cのいずれかを入力したセル列。Target.Column ’OK For cnt = 7 To (6 + nin) If cells(cnt, retsu) = "A" Then a1 = a1 + 1 End If If cells(cnt, retsu) = "B" Then b1 = b1 + 1 End If If cells(cnt, retsu) = "C" Then c1 = c1 + 1 End If Next cnt cells(nin + 7, retsu) = a1 'Ａ番 cells(nin + 8, retsu) = b1 'Ｂ番 cells(nin + 9, retsu) = c1 'Ｃ番 End Sub

  • エクセルVBAのイベントで質問です。

    ダブルクリックイベントで、G12:G31の範囲の文字列をB10:B27の範囲(最下行)に入れていくものを使っていますが、新たにH12:H31にある文字列もダブルクリックするとC10:C27の範囲(最下行)に入れていけるようにしたいと思います。 どのようにすればいいでしょうか。 ご存知の方いらっしゃればお教えいただけると助かります。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, _ Cancel As Boolean) Dim i As Long Dim flg As Boolean If Intersect(Target, Range("G12:G31")) Is Nothing Then Exit Sub If IsEmpty(Target.Value) Then Exit Sub With Worksheets("シートＡ") For i = 10 To 27 If .Range("B" & i).Value = "" Then .Range("B" & i).Value = Target.Value flg = True Exit For End If Next i If flg = False Then MsgBox .Name & " がいっぱいです。" End If End With Cancel = True End Sub

  • マクロで二つの構文を繋ぐには

    いつもお世話になります。 WIN7 EXCELL2010　です。 Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Target.Address = "$A$1" Then Sh.Name = Target.Range("A1").Value End Sub ThisWorkbook　に上記のマクロに下記のマクロを追加したいのですが、 End Sub の　ところを　End If　End With などに変えたのですがうまくゆきません。 御指導お願いできませんでしょうか。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Dim myRange As Range Set myRange = Intersect(Target, Range("M3:V27")) If Not myRange Is Nothing Then Select Case Target.Value Case "" Target.Value = "○" Case "○" Target.Value = "●" Case Else Target.ClearContents End Select Cancel = True End If End Sub 宜しくお願いいします。

  • マクロで分岐をさせる方法

    下記の記録マクロでWith→End With　間にIFで分岐を試みたのですが エラーになります。どうすれば出来るのか伝授をお願いします。 マクロは初心者です。 Dim hensuh(2) As Integer Dim dekiru As Long Dim kinek As Long Dim uineu As Long Dim myTime As Date Dim flg As Boolean Sub OnTimeSamp1() Application.OnTime EarliestTime:=TimeValue("09:00:00"), Procedure:="Ontime_Set" '記録開始 Application.OnTime EarliestTime:=TimeValue("11:00:00"), Procedure:="Ontime_Reset" '記録終了 End Sub Sub Ontime_Set() 'トグルになっている If flg = False Then flg = True myTime = Now + TimeSerial(0, 0, 1) ElseIf flg = True Then flg = False Else Exit Sub End If If Range("A1").Value = "" Then Range("A1").Value = Format(Now, "hh:mm:ss") '時間記録（スタート) End If Application.OnTime EarliestTime:=myTime, _ Procedure:="my_Procedure", Schedule:=flg If flg = False Then myTime = 0 End If End Sub Sub my_Procedure() Worksheets("kirokuyou").Activate 'ワークシートをアクティブにする。（記録中別のワークシートを開けた場合そこに記録されてしまうのを防ぐ） With Range("A65536").End(xlUp).Offset(1) .Value = Format(Now, "yyyy:mm:dd:hh:mm:ss") '時間記録 .Offset(, 1).Value = Range("S3").Value 'S3 の値 .Offset(, 2).Value = Range("T3").Value 'T3 の値 .Offset(, 3).Value = Range("U3").Value 'U3 の値 .Offset(, 4).Value = Range("V3").Value 'V3 の値 dekiru = Range("V3").Value Range("V6").Value = dekiru kinek = Range("T22").Value Range("T18").Value = kinek uineu = Range("U22").Value Range("U18").Value = uineu 'IF S17 >= 120 Then 'hensuh(0) = Range("S17").Value ←変数に代入後、分岐させたいのですがエラーになる 'Elseif S17 >= 110 Then 'hensuh(1) = Range("S17").Value ←変数に代入後、分岐させたいのですがエラーになる 'Elseif S17 >= 100 Then 'hensuh(2) = Range("S17").Value ←変数に代入後、分岐させたいのですがエラーになる 'End If flg = False myTime = 0 End With Call Ontime_Set End Sub Sub Ontime_Reset() 'タイマーリセット On Error Resume Next Application.OnTime EarliestTime:=myTime, _ Procedure:="my_Procedure", Schedule:=False If Err.Number > 0 Then MsgBox "OnTime設定はされていません。", 64 Err.Clear flg = False Else MsgBox myTime & "の設定は解除されました。", 64 flg = False myTime = Empty End If End Sub

  • すべてのシートでマクロを実行したい

    以下のプログラムでは、選択したシートのみマクロが動作しています。ネット検索で見よう見まねで作ったため何がまちがっているのかわかりません。ご教示いただけるとありがたいです。 ・月の予定表で利用者が休みの日に斜線を引くマクロ ・入力ミスを防ぐためシート保護をしている Sub すべてのシート() Dim s As Worksheet For Each s In Worksheets s.Select Call 斜線 Next End Sub Sub 斜線() ActiveSheet.Unprotect Password:="1234" For i = 1 To Range("E10").End(xlDown).Row Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlNone If Range("E10").Value = 0 Then Exit Sub If Cells(i, "E").Value = "日" And Range("BP9").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "月" And Range("BP10").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "火" And Range("BP11").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "水" And Range("BP12").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "木" And Range("BP13").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "金" And Range("BP14").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "E").Value = "土" And Range("BP15").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If If Cells(i, "AY").Value = "祝日" And Range("BP16").Value = 0 Then Range("AS" & i).Borders(xlDiagonalUp).LineStyle = xlContinuous End If Next i ActiveSheet.Protect Password:="1234" End Sub

  • Excel2010 VBA 条件色付け

    Sub sample() Dim r As Range For Each r In Range("q6:q30") If myIsNumeric(r) Then r.Offset(0, 1).Value = "数字" Else r.Offset(0, 1).Value = "文字" End If Next End Sub Function myIsNumeric(Target As Range) Dim r As Range Dim buf, tmp Dim flg As Boolean Dim i As Integer buf = Target For i = 1 To Len(buf) tmp = Mid(buf, i, 1) If IsNumeric(tmp) Then flg = True Exit For End If Next myIsNumeric = flg End Function を数字が入ってたら塗りつぶさないで、 数字が入ってなかったら塗りつぶすように直したいです。 あああ→塗る あああ1－1→塗らない 住所→塗る 住所12→塗らない

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する