Excel：同じ列にデータを再現することを強調表示

Question

Excelで並べ替えられたデータの列（D）が = TEXT（B2、 "###"）です。 これは、追加の「REP 1」を持つデータのリスト（数字）を表示するためのものです。

すべてのデータに「REP 1」があるわけではありませんので、BOTHと「REP 1」を含むすべてのフィールドを強調したいと思います。 I はすべての "REP 1"フィールドを強調表示し、その前に重複があるかどうかを確認できますが、これは単なるサンプルシートです。私には8,000以上のフィールドがあり、時間がかかりすぎるでしょう。私はこのすべてが理にかなって願っています

Required Formatting

：

例えば、以下のリンクをご覧ください。 ありがとう、

Tim。

Answer 1

条件付き書式設定では可能かどうかはわかりませんが、このVBAコードは機能するはずです。あなたのデータは特定の順序で並べ替える必要はなく、書式設定しているデータがD列にあると仮定します。数100行でテストしたところうまくいきましたので、大きなデータセットでうまくいくはずです。 Iveはコード内のコメントを通じてコードが何をしているのかを説明しようとしました。

  Sub formatCells() 


      Dim x As Variant 
      Dim y As Variant 
      Dim searchval As String 
      Dim a As Variant 
      Dim lastrow As Long 
      Dim rng As Range 

      Application.ScreenUpdating = False ' turn off screen updates 

      lastrow = Cells(Rows.Count, 4).End(xlUp).Row 'find the last blank cell 
      x = 2 'set rownumber 
      y = 4 'set columnnumber 


      While Cells(x, y) <> "" ' create loop 
       If InStr(Cells(x, y), "REP1") Then 'search for string in cell 
        Cells(x, y).Interior.Color = RGB(255, 0, 0) 'if string exists fill cell 

       End If 

      x = x + 1 ' loop 

      Wend ' end loop 

      x = 2 ' reset row number 
      y = 4 ' reset column number 

      While Cells(x, y) <> "" ' create loop 2 
       If Cells(x, y).Interior.Color = RGB(255, 0, 0) And InStr(Cells(x, y), "REP1") Then 'if cells is red and contains Rep1 

        a = Cells(x, y).Value ' set a to equal the cell that is red and and contains REP1 
         searchval = Left(a, Len(a) - 5) 'remove space and REP1 and set value ready for search 

        If searchval <> "" Then 'if theres a search value available run steps below 

         With Range("D1:D" & lastrow) 'set range to be column A 
          Set rng = .Find(What:=searchval, _ 
             After:=.Cells(1), _ 
             LookIn:=xlValues, _ 
             LookAt:=xlWhole, _ 
             SearchOrder:=xlByRows, _ 
             SearchDirection:=xlPrevious, _ 
             MatchCase:=False) 
          If Not rng Is Nothing Then 'If search value is found 
           Application.Goto rng, True ' go to cell 
           ActiveCell.Interior.Color = RGB(255, 0, 0) 'set cell to red 
          End If 
         End With 

        End If 
       End If 

      x = x + 1 'loop 2 

      Wend ' end loop 2 

      End Sub 

EDITは - D

  Sub formatCells() 


     Dim x As Variant 
     Dim y As Variant 
     Dim searchval As String 
     Dim a As Variant 
     Dim lastrow As Long 
     Dim rng As Range 

     Application.ScreenUpdating = False ' turn off screen updates 

     lastrow = Cells(Rows.Count, 2).End(xlUp).Row 'find the last blank cell 
     x = 2 'set rownumber 
     y = 2 'set columnnumber 


     While Cells(x, y) <> "" ' create loop 
      If InStr(Cells(x, y), "REP1") Then 'search for string in cell 
       Cells(x, y).Interior.Color = RGB(255, 0, 0) 'if string exists fill cell 

      End If 

     x = x + 1 ' loop 

     Wend ' end loop 

     x = 2 ' reset row number 
     y = 2 ' reset column number 

     While Cells(x, y) <> "" ' create loop 2 
      If Cells(x, y).Interior.Color = RGB(255, 0, 0) And InStr(Cells(x, y), "REP1") Then 'if cells is red and contains Rep1 

       a = Cells(x, y).Value ' set a to equal the cell that is red and and contains REP1 
        searchval = Left(a, Len(a) - 5) 'remove space and REP1 and set value ready for search 

       If searchval <> "" Then 'if theres a search value available run steps below 

        With Range("B1:B" & lastrow) 'set range to be column A 
         Set rng = .Find(What:=searchval, _ 
            After:=.Cells(1), _ 
            LookIn:=xlValues, _ 
            LookAt:=xlWhole, _ 
            SearchOrder:=xlByRows, _ 
            SearchDirection:=xlPrevious, _ 
            MatchCase:=False) 
         If Not rng Is Nothing Then 'If search value is found 
          Application.Goto rng, True ' go to cell 
          ActiveCell.Interior.Color = RGB(255, 0, 0) 'set cell to red 
         End If 
        End With 

       End If 
      End If 

     x = x + 1 'loop 2 

     Wend ' end loop 2 

     End Sub