VBAで色カウント シートの保護について

質問

いつもお世話になります。
WIN7 EXCELL2010です。

B9 : AF154 の範囲のセルに背景色を付けコマンドボタンをクリックすると参照図のように「B5 : AF8」にカウントされます。
例えば　C10 青が　C5に1とカウントされるようマクロをしています。

幾人かの人で入力することからこの「B5 : AF8」の範囲を間違いない扱いを防ぐために

B5 : AF8
セルの書式　保護　ロック(チェックしたまま)　を設定
B9 : AF154
セルの書式　保護　ロック(チェックを外す)　を設定

シートの保護　をしてC10 青にしてコマンドボタンをクリックすると
丸の中に×で　400　とでます。
これを解決する方法はありますか。
もしいい方法があればご指導いただけないでしょうか。
よろしくお願いします。

下記のマクロで参考に
Sub 色付きセル()
Dim i As Long, j As Long, k As Long, endRow As Long, endCol As Long
endRow = ActiveSheet.UsedRange.Rows.Count
endCol = Cells(5, Columns.Count).End(xlToLeft).Column
Range("B5:AF8").ClearContents
For j = 2 To endCol
For i = 5 To 8
For k = 9 To 147
If Cells(k, j).Interior.Color = Cells(i, "A").Interior.Color Then
Cells(i, j) = Cells(i, j) + 1
End If
Next k
Next i
Next j
End Sub

回答No.5

eden3616 · ベストアンサー

>シートの保護の解除のテキストボックスが出ます。

パスワード付きで保護をかけているということですね。

回答No1の修正は「せず」に、

(1)Alt+F11で「Microsoft Visual Basic」を開く
(2)左上のペインで「VBAProject(開かれているブック名)」内にある「ThisWorkbook」をダブルクリック
(3)右上のペインに以下のコードを張り付け

Private Sub Workbook_Open()
ActiveSheet.Unprotect Password:="設定したパスワード"
ActiveSheet.Protect UserInterfaceOnly:=True, Password:="設定したパスワード"
ActiveWindow.ScrollRow = 1
End Sub

(4)(3)のコードの中で「設定したパスワード」のとこをご自身の設定されたパスへ変更
(5)(1)で開いた「Microsoft Visual Basic」を閉じて、上書き保存
(6)ブックを開き直す

以降、「UserInterfaceOnly:=True」設定でシートがパスワード保護されて開くようになります。
この状態でボタンに登録した「色付きセル」マクロが実行できると思います。

■コード内に記述したパスワードが読み取られることを防ぐ方法

上記説明の(2)でダブルクリックした「ThisWorkbook」を右クリックして「VBAProjectのプロパティ」
「保護」タブ内の「プロジェクトを非表示用にロックする」にチェックを入れて、
パスワードを設定後上書きして開き直すと、コードの閲覧時にパスワードが要求されるようになります。

お礼

添付画像までしていただいたご指導まことにありがとございました。

回答No.4

chie65536（@chie65535）

訂正

=GetColorMatchCount($A5,B$6:B$1000)
は
=GetColorMatchCount($A5,B$9:B$1000)
の間違いでした。

なお「セルの値をDELキーで消すと背景色無しに、セルに１～４の値を入力すると背景色に対応した色が付く」と言う方式にすると、5～8行目の式は

5行目
=COUNTIF(B$9:B$1000,"=1")

6行目
=COUNTIF(B$9:B$1000,"=2")

7行目
=COUNTIF(B$9:B$1000,"=3")

8行目
=COUNTIF(B$9:B$1000,"=4")

と言う式で済んでしまいます。

先ほどの回答の、背景色が付いているセルの数を数えて返す関数は、エクセルの仕様の問題で「値の更新がワンテンポ遅れてしまう」と言う問題が起きますが、COUNTIF関数で「セルの値が指定の値になっている個数を調べる」と言う方式なら、値の更新が遅れる事はありません。

このCOUNTIFを用いた方法だと「DELキーで値を消すか、１～４を入力すれば、瞬時に個数が反映される」ので、コマンドボタンもマクロも不要です。

お礼

御指導いただき誠に有難うございました。
非常に参考になることばかりでした。

回答No.3

chie65536（@chie65535）

因みに。

標準モジュールに、以下の関数を作成して、

Function GetColorMatchCount(ByRef MatchRange As Range, ByRef TargetRange As Range) As Variant
Dim count As Integer
count = 0
For Each r In TargetRange
If MatchRange.Item(1).Interior.Color = r.Interior.Color Then
count = count + 1
End If
Next
If count <> 0 Then
GetColorMatchCount = count
Else
GetColorMatchCount = ""
End If
End Function

B5セルに

=GetColorMatchCount($A5,B$6:B$1000)

と言う式を書いて、B6～AF8にコピー、ペーストしてあげると、「色付きセル」マクロを呼ばなくて済むので、コマンドボタンが要らなくなります（セルに色付けした直後にそのセルでDELキーを押せば式の値が反映されます）

B5～AF8セルに条件付書式で、条件１に「1以上なら背景色を付ける」、条件２に「空白なら背景色なしにする」としておくのをお忘れなく。

もうちょっと工夫すると「セルの値をDELキーで消すと背景色無しに、セルに１～４の値を入力すると背景色に対応した色が付く」と言うのも可能になります。

こうすると「書式⇒セル⇒パターン⇒色を選ぶ⇒OKボタン」と言う手間をかけずに済みます。

回答No.2

chie65536（@chie65535）

Sub 色付きセル()
Dim i As Long, j As Long, k As Long, endRow As Long, endCol As Long
ActiveSheet.Unprotect
endRow = ActiveSheet.UsedRange.Rows.Count
endCol = Cells(5, Columns.Count).End(xlToLeft).Column
Range("B5:AF8").ClearContents
For j = 2 To endCol
For i = 5 To 8
For k = 9 To 147
If Cells(k, j).Interior.Color = Cells(i, "A").Interior.Color Then
Cells(i, j) = Cells(i, j) + 1
End If
Next k
Next i
Next j
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub

回答No.1

eden3616

ロックされた箇所の値を削除しようとしてるからでしょう。

Range("B5:AF8").ClearContents
の上に
ActiveSheet.Protect UserInterfaceOnly:=True
を入れてみてください。

補足

早速の御指導ありがとうございます

次のように
B5 : AF8
セルの書式　保護　ロック(チェックしたまま)　を設定
B9 : AF154
セルの書式　保護　ロック(チェックを外す)　を設定
しシートの保護をしてセルに色をつけコマンドボタンをクリックすると
シートの保護の解除のテキストボックスが出ます。

シートの保護がされたままでセルに色付けされたのをカウントさせたいのです

再度ご指導いたたけませんか