Macro to highlight Positive and Negative Numbers

[jdoggie]

Hello,
Does anyone know of a macro that will search a column in Excel and highlight duplicates positive and negative numbers. Any assistance is greately appreciated.

Values A
100
200
300
400
500
600
700
800
-100
-200
-300
-400
-500
-600
700
800

<COLGROUP><COL style="WIDTH: 48pt" width=64><TBODY>
</TBODY>

 

[Trebor76]

Re: Excel: Macro to highlight Positive and Negative Numbers

What about if there's more than three matching positive and negative numbers?

 

[Feroz90]

Re: Excel: Macro to highlight Positive and Negative Numbers

Yes, we may have a chance of getting same numbers, but it is OK, if it applies the same color for those.

 

[Trebor76]

Re: Excel: Macro to highlight Positive and Negative Numbers

So what is supposed to happy if there's more than three matches? You said yellow for first match 100 v -100, red for second 200 v -200 and green for third 300 v -300. What other matches like 400 v -400, 500 v -500 etc? Do you mean to start back to yellow again?

 

[Feroz90]

Re: Excel: Macro to highlight Positive and Negative Numbers

Sorry for the late response.

It may sound odd, but I need at least 10 different colors first, then we may start back with the same list of colors.

100 v -100 - Yellow
200 v -200 - Red
300 v -300 - Green
400 v -400 - Blue
500 v -500 - Orange
600 v -600 - Pink
700 v -700 - Violet
800 v -800 - Black
900 v -900 - Magenta
1000 v -1000 - Cyan

Thank you so much for your effort Robert.

 

[Trebor76]

Re: Excel: Macro to highlight Positive and Negative Numbers

Try this:

Option Explicit
Sub Macro1()

    'Written by Trebor76
    'https://www.mrexcel.com/forum/excel-questions/684674-excel-macro-highlight-positive-negative-numbers.html
           
    Dim lngStartRow As Long, lngEndRow As Long
    Dim rngCell As Range, rngMyData As Range
    Dim lngMyCount As Long
    
    lngStartRow = 2 'Starting row number for the data. Change to suit.
    lngEndRow = Range("D:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        
    Set rngMyData = Range("D" & lngStartRow & ":K" & lngEndRow)
    
    Application.ScreenUpdating = False
    
    For Each rngCell In rngMyData
        If Len(rngCell) > 0 And rngCell.Interior.Color = 16777215 Then
            If lngMyCount > 10 Then
                lngMyCount = 1
            Else
                lngMyCount = lngMyCount + 1
            End If
            Call HighlightOppositeSign(rngCell.Address, rngMyData.Address, lngMyCount)
        End If
    Next rngCell
    
    Set rngMyData = Nothing
    
    lngMyCount = 0
    
    Application.ScreenUpdating = True
    
    MsgBox "Process is now complete"
    
End Sub
Sub HighlightOppositeSign(strCellAddress As String, strDataRange As String, lngMyCount As Long)

    Dim rngCell As Range, rngMyData As Range
    Dim dblMyAmt As Double
    
    dblMyAmt = CDbl(Range(strCellAddress))
    
    For Each rngCell In Range(strDataRange)
        If rngCell.Address <> strCellAddress Then
            If rngCell.Value = dblMyAmt * -1 Then
                If rngCell.Interior.Color = 16777215 Then
                    Select Case lngMyCount
                        Case Is = 1 'Yellow for 1st match
                            Range(strCellAddress).Interior.Color = RGB(255, 255, 0)
                            rngCell.Interior.Color = RGB(255, 255, 0)
                            Exit For
                        Case Is = 2 'Red for 2nd match
                            Range(strCellAddress).Interior.Color = RGB(255, 0, 0)
                            rngCell.Interior.Color = RGB(255, 0, 0)
                            Exit For
                        Case Is = 3 'Green for 3rd match
                            Range(strCellAddress).Interior.Color = RGB(0, 128, 0)
                            rngCell.Interior.Color = RGB(0, 128, 0)
                            Exit For
                        Case Is = 4 'Blue for 4th match
                            Range(strCellAddress).Interior.Color = RGB(0, 0, 255)
                            rngCell.Interior.Color = RGB(0, 0, 255)
                            Exit For
                        Case Is = 5 'Orange for 5th match
                            Range(strCellAddress).Interior.Color = RGB(255, 165, 0)
                            rngCell.Interior.Color = RGB(255, 165, 0)
                            Exit For
                        Case Is = 6 'Pink for 6th match
                            Range(strCellAddress).Interior.Color = RGB(255, 192, 203)
                            rngCell.Interior.Color = RGB(255, 192, 203)
                            Exit For
                        Case Is = 7 'Violet for 7th match
                            Range(strCellAddress).Interior.Color = RGB(238, 130, 238)
                            rngCell.Interior.Color = RGB(238, 130, 238)
                            Exit For
                        Case Is = 8 'Black for 8th match. Note changed the font to white or else you won't see the number
                            With Range(strCellAddress)
                                .Interior.Color = RGB(0, 0, 0)
                                .Font.Color = RGB(255, 255, 255)
                            End With
                            With rngCell
                                .Interior.Color = RGB(0, 0, 0)
                                .Font.Color = RGB(255, 255, 255)
                            End With
                            Exit For
                        Case Is = 9 'Magenta for 9th match
                            Range(strCellAddress).Interior.Color = RGB(255, 0, 255)
                            rngCell.Interior.Color = RGB(255, 0, 255)
                            Exit For
                        Case Is = 10 'Cyan for 10th match
                            Range(strCellAddress).Interior.Color = RGB(0, 255, 255)
                            rngCell.Interior.Color = RGB(0, 255, 255)
                            Exit For
                    End Select
                End If
            End If
        End If
    Next rngCell

End Sub

 

[Feroz90]

Re: Excel: Macro to highlight Positive and Negative Numbers

Hey Robert, It works, I really appreciate your effort. It is been a great pleasure.

Thank you for your efforts again.

If at all I need to learn all such things, how to learn it. Is there any material for learning all these stuffs. Please let me know.

Thank you again

 

[Peter_SSs]

Re: Excel: Macro to highlight Positive and Negative Numbers

Here is another approach you may wish to consider. It is more compact and also has a lot less looping. I don't know how big your data is but in my testing this was also considerably faster.
BTW, I also changed black to grey in the list of colours so that the font colour did not also need to be changed for those cells.

Sub HighlightOpposites()
  Dim myColors As Variant
  Dim rData As Range, cell As Range, rFound As Range
  Dim lr As Long, k As Long

  Const fr As Long = 2 '<- First row of data
  
  myColors = Split("27 3 4 32 45 38 29 16 26 8")
  lr = Range("D:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
  Set rData = Range("D" & fr, Range("K" & lr))
  Application.ScreenUpdating = False
  For Each cell In rData
    If Not IsEmpty(cell.Value) Then
      If Left(cell.Value, 1) <> "#" Then
        Set rFound = rData.Find(What:=-cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rFound Is Nothing Then
          Union(cell, rFound).Interior.ColorIndex = myColors(k)
          cell.Value = "#" & cell.Value
          rFound.Value = "#" & rFound.Value
          k = k + 1
          If k > UBound(myColors) Then k = 0
          Set rFound = Nothing
        End If
      End If
    End If
  Next cell
  rData.Replace What:="#", Replacement:="", LookAt:=xlPart
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

 

[Trebor76]

Re: Excel: Macro to highlight Positive and Negative Numbers

Hi Feroz90,

Thanks for letting us know and you're welcome. I'm glad we got there in the end

Make sure to try Peter_SSs solution as it looks pretty nifty and he would have spent some time putting it together.

Regards,

Robert

 

[Peter_SSs]

Re: Excel: Macro to highlight Positive and Negative Numbers

I've tweaked the code slightly & also marked where you could easily add more colours if you want.
See here for a list of the available ColorIndex values & colours

Sub HighlightOpposites_v2()
  Dim myColors As Variant
  Dim rData As Range, cell As Range, rFound As Range
  Dim lr As Long, k As Long

  Const fr As Long = 2 '<- First row of data
  
  myColors = Split("27 3 4 32 45 38 29 16 26 8") '<- If want more colours add them here.
  lr = Range("D:K").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
  Set rData = Range("D" & fr, Range("K" & lr))
  Application.ScreenUpdating = False
  For Each cell In rData
    If IsNumeric(cell.Text) Then
      Set rFound = rData.Find(What:=-cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
      If Not rFound Is Nothing Then
        Union(cell, rFound).Interior.ColorIndex = myColors(k)
        cell.Value = "#" & cell.Value
        rFound.Value = "#" & rFound.Value
        k = k + 1
        If k > UBound(myColors) Then k = 0
        Set rFound = Nothing
      End If
    End If
  Next cell
  rData.Replace What:="#", Replacement:="", LookAt:=xlPart
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

 

[Feroz90]

Re: Excel: Macro to highlight Positive and Negative Numbers

Great Work Robert and Peter. Thank you both for your kindness.

It is been pleasure to have guys like you.

Thanks