エクセルVBAで指定したセルへジャンプするコード(追加の質問です)

質問

昨日、エクセルVBAで指定したセルへジャンプするコードで質問させていただき、よい方々にご回答いただき、解決する

ことができました。
http://oshiete1.goo.ne.jp/qa2902184.html

考えているうちに欲がでてきて、次のようなこともできればと考え再び質問に参りました。
コードは昨日Nayuta_Xさんが、最初にご提示いただいて、それをもとに付加していただいたmerlionXXのコードをお借りして下に載せました。
そのコードで追加したいことは、
1.ジャンプしたセルに色をつけ、次へ移る際に色を消しますが、最初から色のついたセルの場合その色も消えるので、最初の色に戻したい

2.「設定」シートのA列にシート名、B列にセル番地をつけていますが、C列にコメント欄を設けて、セルにコメントを挿入できるようにして、次に移る際、コメントを削除する。(コメントは、できることならコメントのサイズに合わせて、表示状態にする)

この２点を追加できたらうれしいです。以下のコードに追加できますか？

Sub test01()

Dim x As String
Dim Workbook_Name As String
Dim ThisSheet_Name As String
Dim Sheet_Name As String
Dim ThisRange_Name As String
Dim Range_Name As String
Dim I As Integer, n As Integer
Dim Ans As Integer

ThisSheet_Name = ActiveSheet.Name '設定シート

Select Case Workbooks.Count
Case 1
MsgBox "他に開いているBOOKはありません。"
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 "他に開いているBOOKが複数のため対象を特定できません。"
Exit Sub
End Select

Workbook_Name = x '開いている“もうひとつのブック”の名前

I = 0

' 開きたい　シートは、A列の３行目から　セル番号は、B列の３行目から記入すること。

Do While (1)

With ThisWorkbook.Sheets(ThisSheet_Name)

If .Range("A3").Offset(I, 0).Value = "" Then
MsgBox "データがなくなりました。"
ThisWorkbook.Activate
Exit Do
End If
'A列の３行目以下が、空白なら終わる

Sheet_Name = .Range("A3").Offset(I, 0).Value
Range_Name = .Range("B3").Offset(I, 0).Value

End With

Windows(Workbook_Name).Activate
Sheets(Sheet_Name).Select
Range(Range_Name).Select
Selection.Interior.ColorIndex = 6

Ans = MsgBox("「次に進みますか？」", vbYesNo)

Selection.Interior.ColorIndex = xlNone

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

Loop

End Sub

回答No.4

merlionXX · ベストアンサー

こんにちは。
こうでしょうかね。

Sub test01()

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.AddComment
.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

お礼

merlionXXさん、またお世話になりました。見事に解決されています。
感動です。何年勉強しても私はここまで仕上げるのは無理でしょうね・・・。ありがとうございました。

回答No.3

Nayuta_X

Sheet_Name = Range("A3").Offset(I, 0).Value
Range_Name = Range("B3").Offset(I, 0).Value
myComment = Range("C3").Offset(I, 0).Value　'ここが、抜けています。

回答No.2

Nayuta_X

下記を追加するのを忘れました。
尚、コメントのサイズは、文字数に、合わせることは、出来ません。

Dim Colors As Integer

回答No.1

Nayuta_X

' 下記で良いのでしょうか??
'　修正部分のみ　記入してます。

Dim myComment As String '新規追加

Windows(Workbook_Name).Activate
Sheets(Sheet_Name).Select
Range(Range_Name).Select

Colors = Selection.Interior.ColorIndex '新規追加　
Selection.Interior.ColorIndex = 6

　　'以下　 '新規追加

With Selection.AddComment
.Visible = True
.Text myComment
End With

Range(Range_Name).Select

Ans = MsgBox("「次に進みますか？」", vbYesNo)

If Ans = vbYes Then
I = I + 1
Selection.Interior.ColorIndex = Colors　'修正
Selection.ClearComments　　 '新規追加

Else　'以下同様
Selection.Interior.ColorIndex = Colors
Selection.ClearComments
Exit Do

補足

Nayuta_Xさん、きのうに続いてありがとうございます。追加していただいた部分を昨日のコードに追加して記述しましたが、無知で、コードを挿入した部分が間違っているのか、とまってしまいます。とまるのは、
With Selection.AddComment
.Visible = True
.Text myComment
End With
の.Text myCommentの部分が黄色くなっています。間違いはどこでしょうか？

Sub test01()

Dim x As String
Dim Workbook_Name As String
Dim ThisSheet_Name As String
Dim Sheet_Name As String
Dim ThisRange_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

Workbook_Name = x '開いている“もうひとつのブック”の名前

I = 0

' 開きたい　シートは、A列の３行目から　セル番号は、B列の３行目から記入すること。

Do While (1)

With ThisWorkbook.Sheets(ThisSheet_Name)

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

Sheet_Name = .Range("A3").Offset(I, 0).Value
Range_Name = .Range("B3").Offset(I, 0).Value

End With

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

With Selection.AddComment
.Visible = True
.Text myComment
End With

Range(Range_Name).Select

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

Selection.Interior.ColorIndex = xlNone

If Ans = vbYes Then
I = I + 1
Selection.Interior.ColorIndex = Colors '修正
Selection.ClearComments '新規追加

Else

Selection.Interior.ColorIndex = Colors
Selection.ClearComments

Exit Do
End If

Loop

End Sub