VBA to format tange of cells based off value in another cell

[Access Beginner]

I’m looking to format a range of cells based on a value in othercells.

On the “Menu” sheet I have the following table

Menu Sheet
Cell	Measure	Number Format
A119	T1.1	$
A120	T1.2	%
A121	T1.3	%
A122	T1.4	%
A123	T1.5	#,###,###
A124	T2.1	#,###,###
A125	T2.2	%
A126	T2.3	#,###,###
A127	T2.4	$
A128	T3.1	%

<tbody> </tbody>

In Cell B119 I have T1.1 and C119 I have the format I wantand so on down to B128.

On the “ISS_Charts” sheet in cells R64,R65,and R66 will havevalues ranging from T1.1 to T3.1. These values will change based on a drop downbox in another cell.

So in R64 if the value is T1.1 I’d like on sheet “ISS_Charts”,cellsC16,D16 and E16 to have the format of $. If R64 has the value of T1.2 I’d like cells,C16,D16and D16 to have the format of $ and so on.


Value in R65 determines the values on sheet “ISS_Charts” cellsC25,D25,E25.


Value in R66 determines the values on sheet “ISS_Charts” cellsC31,D31,E31.

I hope the above makes sense.

 

[shknbk2]

Paste this code in the Sheet module for the ISS_Charts worksheet:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim FormatType As String
    Dim RangeToFormat As Range
    
    Select Case Target.Address
        Case "$R$64"
            FormatType = GetFormat(Target.Value)
            Set RangeToFormat = Range("C16:E16")
        Case "$R$65"
            FormatType = GetFormat(Target.Value)
            Set RangeToFormat = Range("C25:E25")
        Case "$R$66"
            FormatType = GetFormat(Target.Value)
            Set RangeToFormat = Range("C31:E31")
        Case Else
            Exit Sub
    End Select
    
    Select Case FormatType
        Case "$"
            RangeToFormat.Style = "Currency"
        Case "%"
            RangeToFormat.Style = "Percent"
        Case Is <> ""
            RangeToFormat.NumberFormat = FormatType
    End Select
End Sub

Private Function GetFormat(Lookup As String) As String
    Dim FoundCell As Range
    Dim LastCell As Range
    
    With Worksheets("Menu").Range("B119:B128")
        Set LastCell = .Cells(.Cells.Count)
    End With
    
    Set FoundCell = Worksheets("Menu").Range("B119:B128").Find(what:=Lookup, after:=LastCell)
    If Not FoundCell Is Nothing Then
        GetFormat = FoundCell.Offset(0, 1).Value
    End If
End Function

 

[DanteAmor]

Just another way

Private Sub Worksheet_Change(ByVal Target As Range)
  If Not Intersect(Target, Range("R64:R66")) Is Nothing Then
    If Target.Count > 1 Then Exit Sub
    Dim f As Range, r As Long, nf As Variant
    r = WorksheetFunction.Lookup(Target.Row, Array(64, 65, 66), Array(16, 25, 31))
    Set f = Sheets("Menu").Range("B119:B128").Find(Target.Value, , xlValues, xlWhole)
    If Not f Is Nothing Then
      nf = WorksheetFunction.Lookup(Left(f.Offset(, 1), 1), Array("#", "$", "%"), Array("#,###,###", "$0", "0%"))
      Range("C" & r & ":E" & r).NumberFormat = nf
    End If
  End If
End Sub

SHEET EVENT
Right click the tab of the sheet you want this to work, select view code and paste the code into the window that opens up.