赤いテキストのみを削除したい

質問

https://okwave.jp/qa/q9543301.html
の続きになりますが、宜しくお願いします。
「色を指定しているセルのみ値を削除」
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1489525229
検索しましたところ、上記を見つけました。
下記のコードに組み合わせましたが、反映されませんでした。
どこが違うのでしょうか？
宜しくお願いします。

Sub test4()
　　Dim Rng As Range, blanks As Range
　　Dim ar As Range, 列 As Long
　　Dim 開始行 As Long, 最終行 As Long, 最終列 As Long
　　On Error GoTo ErrorHandler
　　　　ActiveSheet.Name = "Sheet1"
　　　　開始行 = 2

　　最終行 = Cells(Rows.Count, "A").End(xlUp).Row
　　最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Column
　　For 列 = 1 To 最終列
　　　　Set Rng = Range(Cells(開始行, 列), Cells(最終行 - 1, 列))
　　　　Rng.VerticalAlignment = xlTop
　　　　Rng.Borders.LineStyle = xlContinuous　' 黒枠配置
　　　　Set blanks = Rng.SpecialCells(xlCellTypeBlanks)
　　　　For Each ar In blanks.Areas
　　　　　　Union(ar(1).Offset(-1), ar).Merge
　　　　Next ar
　　Next 列
　　Cells(最終行, "A").ClearContents

' 赤いテキスト削除
　For 列 = 1 To lasrow
　If Rng.Font.ColorIndex <= 3 Then Rng.Value = ""
　Next

ErrorHandler:
　　If Err Then MsgBox "Error Number = " & Err.Number & Chr(13) & _
　　　　"Error Message = " & Err.Description, , "Debug"
End Sub

回答No.2

watabe007 · ベストアンサー

Sub test()
　　Dim Rng As Range, blanks As Range
　　Dim ar As Range, 列 As Long
　　Dim 開始行 As Long, 最終行 As Long, 最終列 As Long

　　On Error GoTo ErrorHandler
　　開始行 = 2
　　最終行 = Cells(Rows.Count, "A").End(xlUp).Row
　　最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Column
　　For 列 = 1 To 最終列
　　　　Set Rng = Range(Cells(開始行, 列), Cells(最終行 - 1, 列))
　　　　Rng.VerticalAlignment = xlTop
　　　　Rng.Borders.LineStyle = xlContinuous ' 黒枠配置
　　　　Set blanks = Rng.SpecialCells(xlCellTypeBlanks)
　　　　For Each ar In blanks.Areas
　　　　　　'赤いテキスト消去
　　　　　　With ar(1).Offset(-1)
　　　　　　　　If .Font.Color = vbRed Then .ClearContents
　　　　　　　　Union(.Cells, ar).Merge
　　　　　　End With
　　　　Next ar
　　Next 列
　　Cells(最終行, "A").ClearContents
　　Dim c As Range
　　For Each c In Range(Cells(開始行, 1), Cells(最終行 - 1, 最終列))
　　　　'Cセルが結合セルではなく文字色が赤の時、消去
　　　　If Not c.MergeCells And c.Font.Color = vbRed Then c.ClearContents
　　Next
ErrorHandler:
　　If Err Then MsgBox "Error Number = " & Err.Number & Chr(13) & _
　　　　"Error Message = " & Err.Description, , "Debug"
End Sub

お礼

ありがとうございます。
なるほど、セルの結合以外は反映されませんでしたね。
もうひとつ質問ですが、このコードより結合しない場合はどのコードを削除するのでしょうか？どれを削除してもうまくいきませんでした。

回答No.6

watabe007

赤色文字も消去するのなら
　　Dim c As Range
　　For Each c In Range(Cells(開始行, 1), Cells(最終行 - 1, 最終列))
　　　　If c.MergeCells Then c.MergeArea.UnMerge
　　　　If c.Font.Color = vbRed Then c.ClearContents
　　Next

回答No.5

watabe007

>A2からM列の最終まで結合なしで全て黒枠を入れたいのです。
ん？　最後に結合セルを解除してやれば黒枠だけ残るのでは
Sub test7()
　　Dim Rng As Range, blanks As Range
　　Dim ar As Range, 列 As Long
　　Dim 開始行 As Long, 最終行 As Long, 最終列 As Long

　　On Error GoTo ErrorHandler
　　開始行 = 2
　　最終行 = Cells(Rows.Count, "A").End(xlUp).Row
　　最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Column
　　For 列 = 1 To 最終列
　　　　Set Rng = Range(Cells(開始行, 列), Cells(最終行 - 1, 列))
　　　　Rng.VerticalAlignment = xlTop
　　　　Rng.Borders.LineStyle = xlContinuous ' 黒枠配置
　　　　Set blanks = Rng.SpecialCells(xlCellTypeBlanks)
　　　　For Each ar In blanks.Areas
　　　　　　Union(ar(1).Offset(-1), ar).Merge
　　　　Next ar
　　Next 列
　　Cells(最終行, "A").ClearContents
　　Dim c As Range
　　For Each c In Range(Cells(開始行, 1), Cells(最終行 - 1, 最終列))
　　　　'結合セルを解除
　　　　If c.MergeCells Then c.MergeArea.UnMerge
　　Next
ErrorHandler:
　　If Err Then MsgBox "Error Number = " & Err.Number & Chr(13) & _
　　　　"Error Message = " & Err.Description, , "Debug"
End Sub

お礼

ありがとうございます。
この質問は改めて新しく質問しますので、宜しくお願いします。

回答No.4

watabe007

以下で赤いテキストのみを削除できましたよ
Sub Test()
　　Dim c As Range
　　For Each c In Range("A2:G23")
　　　　If c.MergeArea.Cells.Count > 1 Then
　　　　　　If c.MergeArea.Item(1).Font.Color = vbRed Then
　　　　　　　　c.MergeArea.ClearContents
　　　　　　End If
　　　　ElseIf c.Font.Color = vbRed Then
　　　　　　c.ClearContents
　　　　End If
　　Next
End Sub

お礼

これも参考になります。ありがとうございます。

回答No.3

watabe007

>なるほど、セルの結合以外は反映されませんでしたね。　
　With ar(1).Offset(-1)
　　　If .Font.Color = vbRed Then .ClearContents
　　　Union(.Cells, ar).Merge
　End With
　　↑ここでは結合セルしか見ていません。
　　↓ここでは、範囲全体をループして単体のセル(Not c.MergeCells )で
　　　文字色が赤色探して消去しています。変化しませんでしたか？
　　For Each c In Range(Cells(開始行, 1), Cells(最終行 - 1, 最終列))
　　　　'Cセルが結合セルではなく文字色が赤の時、消去
　　　　If Not c.MergeCells And c.Font.Color = vbRed Then c.ClearContents
　　Next
>このコードより結合しない場合はどのコードを削除するのでしょうか？
結合セルが無い場合ですか？
　　↓参考になるかな？
結合セルと単体のセルが混在している範囲をループして
For Each c In Range("A2:M23")
　　'cセルが結合セルであって
　　If c.MergeArea.Cells.Count > 1 Then
　　　　'結合セルの文字色が赤色の場合
　　　　If c.MergeArea.Item(1).Font.Color = vbRed Then
　　　　　　'結合セルを消去
　　　　　　c.MergeArea.ClearContents
　　　　End If
　　'cセルが単体のセルであり文字色が赤色の場合
　　ElseIf c.Font.Color = vbRed Then
　　　　'cセルを消去
　　　　c.ClearContents
　　End If
Next

お礼

説明が足りませんでした。
セル結合のコードをなくしたいってことはセルの結合をしないで、黒枠のみを実行したいのです。
A2からM列の最終まで結合なしで全て黒枠を入れたいのです。
そのコードからどれを削除したらセル結合しないで、黒枠のみ入れることができるのでしょうか？

回答No.1

watabe007

Sub test()
　　Dim Rng As Range, blanks As Range
　　Dim ar As Range, 列 As Long
　　Dim 開始行 As Long, 最終行 As Long, 最終列 As Long

　　On Error GoTo ErrorHandler
　　開始行 = 2
　　最終行 = Cells(Rows.Count, "A").End(xlUp).Row
　　最終列 = Cells(開始行, Columns.Count).End(xlToLeft).Column
　　For 列 = 1 To 最終列
　　　　Set Rng = Range(Cells(開始行, 列), Cells(最終行 - 1, 列))
　　　　Rng.VerticalAlignment = xlTop
　　　　Rng.Borders.LineStyle = xlContinuous ' 黒枠配置
　　　　Set blanks = Rng.SpecialCells(xlCellTypeBlanks)
　　　　For Each ar In blanks.Areas
　　　　　　'赤いテキスト消去
　　　　　　If ar(1).Offset(-1).Font.Color = vbRed Then ar(1).Offset(-1).ClearContents
　　　　　　Union(ar(1).Offset(-1), ar).Merge
　　　　Next ar
　　Next 列
　　Cells(最終行, "A").ClearContents
ErrorHandler:
　　If Err Then MsgBox "Error Number = " & Err.Number & Chr(13) & _
　　　　"Error Message = " & Err.Description, , "Debug"
End Sub

お礼

ありがとうございます。
マクロ実行してみましたが、一部赤いテキストが残っております。
画像を配置します。赤いテキストは全部同じ色です。

補足

画像を配置します。
https://www.dropbox.com/s/csacno562f4viel/1.jpg?dl=0
宜しくお願いします。