How to read a special character (arrow) from one cell in a macro and store it in another

JenniferMurphy

Well-known Member
Joined
Jul 23, 2011
Messages
2,482
Office Version
  1. 365
Platform
  1. Windows
I am trying to write a macro that will read in a column of special characters (up arrow, down arrow, etc.) that indicate whether a value is over or under some range. It will then scan another set of numbers, store the appropriate character in the cell to the left, and apply a color to both cells.

This code works as long as the characters are from the normal character set. But it fails if I select any special characters.

Here's the mini-sheet:

Book2
BCDEFGHIJ
1
2
3
4RatingsValuesExpectedUnrated
560Max8484
640Min3939
79191
8Too high77
9Goldilocks5555
10Too low4040
116161
126060
Sheet1


And here's the macro code. It is invoked by a Button control which is not included in the mini-sheet even though I selected a range that includes it.

VBA Code:
Sub RateEm()

Const rnCodes As String = "Codes"     'Column of code characters & colors
Const rnValues As String = "Values"   'Column of values to be rated
Const rnRatings As String = "Ratings" 'Column to put ratings
Dim Values() As Variant               'Values array
Dim NumValues As Long                 'Number of values

Dim Codes() As Variant    'Code characters
Dim NumCodes As Long      'Number of codes
Dim Colors() As Long      'Category colors

Dim Min As Long     'Minimum good value
Dim Max As Long     'Maximum good value
Dim iRtg As Long    'Rating index
Dim i As Long       'Loop index

Codes = Range(rnCodes).Value  'Read in the character codes & colors
NumCodes = UBound(Codes, 1)   'Number of codes
ReDim Colors(1 To NumCodes)   'Make colors array the same size
For i = 1 To NumCodes         'Get the code colors
  Colors(i) = Range(rnCodes).Cells(i, 1).Interior.Color
Next i

Min = Range("Min").Value        'Get the minimum value
Max = Range("Max").Value        'Get the maximum value
Values = Range(rnValues).Value  'Read in the character codes
NumValues = UBound(Values, 1)   'Get the number of values

For i = 1 To NumValues
  Select Case Range(rnValues).Cells(i, 1)
    Case Is > Max: iRtg = 1
    Case Is < Min: iRtg = 3
    Case Else: iRtg = 2
  End Select
  Range(rnValues).Cells(i, 1).Interior.Color = Colors(iRtg)
  Range(rnRatings).Cells(i, 1).Interior.Color = Colors(iRtg)
  Range(rnRatings).Cells(i, 1).Value = Codes(iRtg, 1)
Next i

End Sub

If I use characters from the normal text character set, it works.

1634174588202.png


But if I use special characters from another character set, I get this:

1634174734868.png


Is there a way I can use any character and make it work?

Thanks
 
A variation to use the named range Codes only once :​
VBA Code:
Sub RateEmR2D2BB8()
    Dim M&, N&, K&(), V, R&, C%, S$
        M = [Max].Value2
        N = [Min].Value2
    With [Codes]
        ReDim K(1 To .Rows.Count)
        For R = 1 To .Rows.Count:  K(R) = .Cells(R).Interior.Color:  Next
        V = .Value2
    End With
        Application.ScreenUpdating = False
    With [Ratings]
           .NumberFormat = "@"
        For R = 1 To .Rows.Count
            With .Cells(R, 2)
                Select Case .Value2
                       Case Is > M:     C = 1:  S = .Value2 - M
                       Case Is < N:     C = 3:  S = N - .Value2
                       Case Else:       C = 2:  S = Format$((.Value2 - N) / (M - N), "0%")
                End Select
            End With
               .Cells(R).Resize(, 2).Interior.Color = K(C)
               .Cells(R).Value2 = V(C, 1) & S
        Next
    End With
        Application.ScreenUpdating = True
End Sub
I do not use the named range Values as it is adjacent to the names range Ratings …​
 
Upvote 0

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Last but not least, if you really want / need to work with named ranges rather than directly with the cells addresses like I did with Demo2 for example​
this is the Ultimate version :​
VBA Code:
Sub RateEmU()
  Const C = "#>¤,#-¤,IF(#<§,§-#,(#-§)/(¤-§)%&""%""))"
    Dim M$, N$, F$, V, R&
        M = [Max].Address
        N = [Min].Address
        Application.ScreenUpdating = False
    With [Ratings].Columns
        F = Replace("(#<=" & M & ")+(#<", "#", .Item(2).Address) & N & ")"
        V = Evaluate("1+" & F)
        For R = 1 To .Rows.Count:  .Cells(R).Resize(, 2).Interior.Color = Range("Codes")(V(R, 1)).Interior.Color:  Next
        F = "=OFFSET(" & Range("Codes")(1).Address & "," & F & ",0)&IF(" & _
            Replace(Replace(Replace(C, "#", .Cells(1, 2).Address(False, False)), "¤", M), "§", N)
       With .Item(1)
            .NumberFormat = "General"
            .Formula = F
            .NumberFormat = "@"
            .Formula = .Value2
       End With
    End With
        Application.ScreenUpdating = True
End Sub
 
Upvote 0
Last but not least, if you really want / need to work with named ranges rather than directly with the cells addresses like I did with Demo2 for example​
this is the Ultimate version​
(Chuckle...) I think you have done more work on this than I have! ? ?

I am using named ranges because (a) there is no way to pass arguments to a sub and (b) some of the ranges are in a global sheet, not the one calling the sub. It seemed like the best solution.
 
Upvote 0

Now you have the choice and enough material for long winter evenings !​
 
Upvote 0
Last but not least, if you really want / need to work with named ranges rather than directly with the cells addresses like I did with Demo2 for example​
this is the Ultimate version :​
I think I was able to figure out most of your code. The F & V variables use a clever expression that assigns a 1, 2, or 3 to values that are over the max, between the max and min, or under the min. Very clever. I would never have thought of that. And I think I understand the triple nested Replace statements . . .

Your code works except for two details: (1) It assumes that the Ratings range is immediately to the left of the Values range. It could be to the right or it could be a column or two away. That's why I gave it a separate name. (2) The code characters in the Codes range do not display correctly in the Ratings range if they are not in the same font as the numbers.

I am going to stick with my original design. Your code is probably more efficient and more elegant, but even if I were able to fully understand what you are doing, if I came back to it in 6 months, it would probably take me as long to figure it out again as it did the first time. I need code I can maintain with my limited VBA expertise.

Rather than fuss with prefix characters from another font, I'll just choose ones from the number font (Calabri 11 at the moment).

With your help, I was able to get everything working. Here's screen shot of my little test sheet before running my code:
1634612062763.png

Columns I & J above are there just to let me reset columns F & G so I could run another test.

Here it is after running my code.
1634612137805.png

That's just about perfect. Thanks very much for the help.

Here's the "final" code. I managed to incorporate a couple of your With . . . End With structures, which does simplify the code. But I need the longer Dim statements for documentation. If you see anything else that could be better, feel free to comment. Thanks.

VBA Code:
'===========================================================================
'     My Prototype Rating Macro for a Blood Glucose Reading Rating Macro
'===========================================================================
Sub RateEm()

Const rnCodes As String = "Codes"     'Column of code characters & colors
Const rnValues As String = "Values"   'Column of values to be rated
Const rnRatings As String = "Ratings" 'Column to put ratings
Dim Values() As Variant               'Values array
Dim NumValues As Long                 'Number of values

Dim Codes() As Variant    'Code characters
Dim NumCodes As Long      'Number of codes

Dim Min As Long     'Minimum good value
Dim Max As Long     'Maximum good value
Dim i As Long       'Loop index

Codes = Range(rnCodes).Value  'Read in the character codes & colors
NumCodes = UBound(Codes, 1)   'Number of codes

Min = Range("Min").Value        'Get the minimum value
Max = Range("Max").Value        'Get the maximum value
Values = Range(rnValues).Value  'Read in the character codes
NumValues = UBound(Values, 1)   'Get the number of values
Dim iValue As Variant           'The numeric value
Dim sValue As String            'The formatted value
Dim iCode As Long               'The code index

For i = 1 To NumValues
  iValue = Range(rnValues).Cells(i, 1)
  Select Case iValue
    Case Is > Max
      iCode = 1
      sValue = Range(rnCodes).Cells(iCode, 1).Value & Format(iValue - Max, "0")
    Case Is < Min
      iCode = 3
      sValue = Range(rnCodes).Cells(iCode, 1).Value & Format(Min - iValue, "0")
    Case Else
      iCode = 2
      sValue = Range(rnCodes).Cells(iCode, 1).Value & Format((iValue - Min) / (Max - Min), "0%")
  End Select
  With Range(rnRatings).Cells(i, 1)       'Make the rating cells look like the values cells
    .NumberFormat = "@"                       'Change to text formatting
    .Value = sValue                           'Store the value including prefix character
    .Interior.Color = _
        Range(rnCodes).Cells(iCode, 1).Interior.Color       'Set the ratings highlight color
    .Font.Name = Range(rnCodes).Cells(iCode, 1).Font.Name   'Copy font
    .Font.Size = Range(rnCodes).Cells(iCode, 1).Font.Size   'Copy font size
    .Font.Color = Range(rnCodes).Cells(iCode, 1).Font.Color 'Copy font color
  End With
  With Range(rnValues).Cells(i, 1)        'Highlight the values cells the same as the ratings
    .Interior.Color = Range(rnCodes).Cells(iCode, 1).Interior.Color 'Set the values highlight color
    .Interior.Color = Range(rnCodes).Cells(iCode, 1).Interior.Color 'Set the values highlight color
  End With
Next i

End Sub
 
Upvote 0
The F & V variables use a clever expression
The constant C & the variable F are just easy worksheet formulas.​
The variable V contains the offset according to the named range 'Codes' as the color index …​
And I think I understand the triple nested Replace statements
As a worksheet formula the 3 specials characters need to be replaced with their respective range address.​
(1) It assumes that the Ratings range is immediately to the left of the Values range.
Exact according to your post #13 attachment as my aim was to lighten your code …​
(2) The code characters in the Codes range do not display correctly in the Ratings range if they are not in the same font as the numbers.
Idem (according to the attachment) but easily solved with the Range.Copy method​
or just applying the same font options to the named range 'Ratings' like you did …​
According to these points my Ultimate version revamped :​
VBA Code:
Sub RateEmUr()
  Const A = "Values", C = "Codes", F = "&IF(#>¤,#-¤,IF(#<§,§-#,(#-§)/(¤-§)%&""%""))"
    Dim M$, N$, V, R&
        M = [Max].Address
        N = [Min].Address
        V = Evaluate("1+" & Replace("(#<=" & M & ")+(#<", "#", Range(A).Address) & N & ")")
        Application.ScreenUpdating = False
    With [Ratings]
        For R = 1 To .Rows.Count
            Range(C)(V(R, 1)).Copy .Cells(R)
            Range(A)(R).Interior.Color = Range(C)(V(R, 1)).Interior.Color
        Next
'           .NumberFormat = "@"
           .Value2 = Evaluate("=" & .Address & Replace(Replace(Replace(F, "#", Range(A).Address), "¤", M), "§", N))
    End With
        Application.ScreenUpdating = True
End Sub
The codeline .NumberFormat = "@" is no more necessary when the character '=' is not used within the named range 'Codes'​
or like I use the Range.Copy method even if '=' is present in this range but with its cell already formatted as text …​
Let's answer to the essential question : what is the best code ?​
The one you understand but far above all the one you're able to maintain yourself ! ;)
 
Upvote 0
VBA Code:
  With Range(rnValues).Cells(i, 1)        'Highlight the values cells the same as the ratings
    .Interior.Color = Range(rnCodes).Cells(iCode, 1).Interior.Color 'Set the values highlight color
    .Interior.Color = Range(rnCodes).Cells(iCode, 1).Interior.Color 'Set the values highlight color
  End With
Can be replaced with​
VBA Code:
    Range(rnValues).Cells(i, 1).Interior.Color = Range(rnCodes).Cells(iCode, 1).Interior.Color 'Set the values highlight color
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,949
Members
448,534
Latest member
benefuexx

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top