こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

投稿日時 - 2018-10-04 21:31:51

QNo.9544306

困ってます

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

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

投稿日時 - 2018-10-05 08:16:13

お礼

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

投稿日時 - 2018-10-05 20:31:41

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(6)

ANo.6

赤色文字も消去するのなら
  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

投稿日時 - 2018-10-05 22:58:39

ANo.5

>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

投稿日時 - 2018-10-05 22:54:24

お礼

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

投稿日時 - 2018-10-06 06:16:28

ANo.4

以下で赤いテキストのみを削除できましたよ
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

投稿日時 - 2018-10-05 22:06:29

お礼

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

投稿日時 - 2018-10-05 22:23:34

ANo.3

>なるほど、セルの結合以外は反映されませんでしたね。 
 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

投稿日時 - 2018-10-05 21:23:22

お礼

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

投稿日時 - 2018-10-05 22:22:47

ANo.1

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

投稿日時 - 2018-10-04 22:29:46

補足

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

投稿日時 - 2018-10-05 06:03:32

お礼

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

投稿日時 - 2018-10-05 05:58:39

あなたにオススメの質問