以前質問し解決した、セルを次々にジャンプについて又質問です。

以前、こちらで別ブックの指定したセル番に飛んで、色付け、コメントを表示、次のセルへ飛ぶ際には色を元に戻し、コメントも取り去る。
というコードを教えていただきました。それは大変役に立ち、教えてくださった方々も何度もかかわっていただいた質問でした。

一年たって新たに問題が出たのでいろいろ構っていたのですが、また質問に参りました。
問題点は、下のコードを実行する際、検査する別ブックにシートの保護がかかっている場合エラーになることです。こればっかりは、そのブックのシート保護を解除しない限り無理でしょうか？
シートの保護はかかっているのですが、飛んでいくセルには編集できるようになっているので、余計に残念です。



Sub oshiete()

Dim x As String
Dim ThisSheet_Name As String
Dim Sheet_Name As String
Dim Range_Name As String
Dim i As Integer, n As Integer
Dim Ans As Integer
Dim myComment As String '新規追加
Dim Colors As Integer '新規追加

ThisSheet_Name = ActiveSheet.Name '設定シート

Select Case Workbooks.Count
Case 1
MsgBox "チェックするファイルがありません。"
Exit Sub
Case 2
For n = 1 To 2
If Workbooks(n).Name <> ThisWorkbook.Name Then
x = Workbooks(n).Name '開いている“もうひとつのブック”の名前
End If
Next
Case Else
MsgBox "他に開いているファイルが複数のため対象を特定できません。"
Exit Sub
End Select

i = 0

Do While (1)

With ThisWorkbook.Sheets(ThisSheet_Name)

If .Range("A3").Offset(i, 0).Value = "" Then
MsgBox "検査項目は以上です。"
ThisWorkbook.Activate
Exit Do 'A列の３行目以下が、空白なら終わる
End If

Sheet_Name = .Range("A3").Offset(i, 0).Value
Range_Name = .Range("B3").Offset(i, 0).Value
myComment = .Range("C3").Offset(i, 0).Value

End With

Windows(x).Activate
Sheets(Sheet_Name).Select
Range(Range_Name).Select
Colors = Selection.Interior.ColorIndex '新規追加
Selection.Interior.ColorIndex = 6

With Selection(1).AddComment '選択範囲の1番目にコメント
.Visible = True
.Text myComment
End With


Range(Range_Name).Select

Ans = MsgBox("「次をチェックしますか？」", vbYesNo)

Selection.Interior.ColorIndex = Colors '修正
Selection.ClearComments '新規追加

If Ans = vbYes Then
i = i + 1
Else
Exit Do
End If

Loop

End Sub

No.3 ベストアンサー 回答者： Wendy02 回答日時： 2008/05/04 21:00

こんばんは。

>で黄色くなっています。

ということで、もし、実行時エラーなら、シートのプロテクトの度合いに問題で、私は、エラー回避するのを忘れていました。

On Error Resume Next
With ActiveCell
　.Interior.ColorIndex = xlNone
　.ClearComments
msg = ""
End With
On Error Goto 0

とはさむしか、回避する方法はないと思います。

まあ、皆さんが以前に作ったものと、それほどに変わるわけではありませんが、考え方のプロセスがちょっと違うだけです。

この回答へのお礼

Wendy02さんおはようございます。
またお世話になりました。バージョンアップできて助かりました。いろいろお考えいただいていつもありがとうございます。

お礼日時：2008/05/05 10:35

No.2 回答者： Wendy02 回答日時： 2008/05/04 12:19

こんにちは。

これは、1年越しに醸成されながら作られたマクロのようですから、私も、前のいきさつを読みながら、私なりに考えてみました。

対話型のマクロというのは、難しい割には、成果が少ないようです。本当は、コンセプト自体を変えて、目的に沿った別な方法があるような気がしてならないのですが、ここで、数名の方が携わってきて、今更、白紙に戻して、最初から直すということもできないはずです。

私自身も以下を小一時間で作ってみましたが、たいしたものは作れませんでした。要するに、キャンセルを押したら、それで、そのマクロはおしまいですね。ただ、そこで調整して、中途から行うということは可能です。また、プロテクトにも種類がありますから、ある程度のこと可能です。

今回の質問に関しては、プロテクトに関しては、直接ではないにしても、以下のように、結果的には、プロテクトを一回外して、マクロ側で使えるように、外すというような作業が必要になってしまいます。本来、Comment を書き込むというようなことがなければ、もう少しすっきりとはしますが。


例：

　With Worksheets("Sheet1")
　 .Unprotect Password:="PWS"
　 .Protect Password:="PWS", UserInterfaceOnly:=True
　End With

UserInterfaceOnly　のHelpの解説
引数 UserInterfaceOnly に True を設定した Protect メソッドをブックのワークシートに適用した場合、保存して閉じた後でもう一度開いたブックに対しては、画面上からもマクロからも変更ができなくなります。マクロからの変更を可能にするためには、引数 UserInterfaceOnly に True を設定した Protect メソッドを再び適用する必要があります。

<<試案>>
''----------------------------------
''標準モジュールが良いです。
''これは、プロテクトされていたら、on protect という表示と、メッセージが、Msgbox に現れる形になります。
''-----------------------------------

Sub TestMacro()
　　Dim c As Range
　　Dim ret As Variant
　　Dim wb As Workbook
　　Dim opWb As Workbook
　　Dim arAdd(2, 20) As String '設定は20項目まで
　　Dim myCol As Long
　　Dim n As Integer
　　Dim msg As String
　　Dim i As Integer
　　Dim j As Long
　　Dim lastnum As Long
　　With ThisWorkbook.ActiveSheet
　　　　For Each c In .Range("A3", .Range("A65536").End(xlUp))
　　　　　　If c.Value <> "" And c.Offset(, 1).Value <> "" Then
　　　　　　　　ret = Application.Evaluate("=" & c.Value & "!" & c.Offset(, _
　　　　　　　　1).Value)
　　　　　　　　If IsError(ret) Then
　　　　　　　　　　MsgBox "正しくシートに入れられていません。", 48
　　　　　　　　　　Exit Sub
　　　　　　　　End If
　　　　　　　　arAdd(0, j) = c.Value
　　　　　　　　arAdd(1, j) = c.Offset(, 1).Value
　　　　　　　　arAdd(2, j) = c.Offset(, 2).Value
　　　　　　　　j = j + 1
　　　　　　End If
　　　　Next c
　　End With
　　lastnum = j - 1
　　For Each wb In Workbooks
　　　　'可視ブックスの数を数える
　　　　If wb.Windows(1).Visible And Not wb Is ThisWorkbook Then
　　　　　　If opWb Is Nothing Then
　　　　　　　　Set opWb = wb
　　　　　　Else
　　　　　　　　MsgBox "複数の可視ブックが開かれています。", 48
　　　　　　　　Set opWb = Nothing
　　　　　　　　Exit Sub
　　　　　　End If
　　　　End If
　　Next wb
　　If opWb Is Nothing Then
　　　　MsgBox "もうひとつの可視ブックが、開かれていません。", 48
　　　　Exit Sub
　　End If
　　For j = 0 To lastnum
　　　　Application.Goto opWb.Worksheets(arAdd(0, j)).Range(arAdd(1, j)), True
　　　　On Error Resume Next
　　　　Call ScreenCenter(ActiveCell)
　　　　On Error GoTo 0
　　　　On Error Resume Next
　　　　With ActiveCell
　　　　　　.Interior.ColorIndex = 6
　　　　　　.AddComment.Text arAdd(2, j)
　　　　　　.Comment.Visible = True
　　　　　　n = Err.Number
　　　　End With
　　　　On Error GoTo 0
　　　　If n = 91 Then msg = " on protect" & vbCrLf & arAdd(2, j)
　　　　If j < lastnum Then
　　　　　　If MsgBox( _
　　　　　　　　"現在の場所： & " & ActiveSheet.Name & "!" & ActiveCell.Address(0, 0) & _
　　　　　　　　msg & vbCrLf & vbCrLf & _
　　　　　　　　"次に進みますか？ " & _
　　　　　　　　arAdd(0, j + 1) & "!" & arAdd(1, j + 1), _
　　　　　　　　vbOKCancel, "プロセス " & j + 1 & "/" & lastnum + 1) = vbCancel _
　　　　　　　　Then
　　　　　　　　Exit For
　　　　　　End If
　　　　Else
　　　　　　MsgBox "現在の場所：" & ActiveSheet.Name & "!" & ActiveCell.Address(0, 0) & _
　　　　　　vbCrLf & vbCrLf & "これで終了です。 " & msg, _
　　　　　　64, "プロセス " & j + 1 & "/" & lastnum + 1
　　　　End If
　　　　With ActiveCell
　　　　　　.Interior.ColorIndex = xlNone
　　　　　　.ClearComments
　　　　　　msg = ""
　　　　End With
　　Next j
　　'戻る場所
　　Application.Goto ThisWorkbook.ActiveSheet.Range("A3")
　　Set opWb = Nothing
End Sub

Private Sub ScreenCenter(ac As Range)
　　'Scrolls Control
　　Dim acRow As Long
　　Dim myRow As Long
　　Dim acCol As Integer
　　Dim myCol As Long
　　With ActiveWindow
　　　　acRow = ac.Row
　　　　acCol = ac.Column
　　　　'Screen upper one third
　　　　myRow = .VisibleRange.Rows.Count - Int(.VisibleRange.Rows.Count / 3) * 2
　　　　If acRow > myRow Then
　　　　　　.ScrollRow = acRow - myRow
　　　　Else
　　　　　　.ScrollRow = 1
　　　　End If
　　　　
　　　　myCol = Int(.VisibleRange.Columns.Count / 2)
　　　　If acCol > myCol Then
　　　　　　.ScrollColumn = acCol - myCol
　　　　Else
　　　　　　.ScrollColumn = 1
　　　　End If
　　End With
End Sub

この回答へのお礼

Wendy02さんこんにちは。いつもお世話になります。
この質問の際にも大変お世話になり、私にとって大変有益なものを提示いただきました。
今回の質問でまた時間を作っていただきご提示いただきありがとうこざいます。早速ためさせていただきましたところ、以下のところでとまってしまいました。
With ActiveCell
.Interior.ColorIndex = xlNone
.ClearComments
msg = ""
End With
この
.Interior.ColorIndex = xlNone
で黄色くなっています。
私の理解不足で貼付、設定など間違っていたら申し訳ありません。
TestMacro　とPrivate Subを標準モジュールに貼り付けています。

お礼日時：2008/05/04 17:33

No.1 回答者： mitarashi 回答日時： 2008/05/04 01:34

質問への直接の回答ではありませんが、

一手間かけるつもりになれば、保護されたシートを、そのまま別ブックのシートに丸ごとコピーして、保護無し状態で再現する事は容易です。（A1セルの左上の空白のマスをクリックして、シート全体をコピーし、空シートにペースト。但し、セル内の文字数が255文字以上の時は、制約あり）
検査対象ブックをそのまま提出しなければいけない様な場合は無理ですが、ご参考まで。また、Excel2000での話です。