Option Explicit
' ----------------------------------------------------------------
' Procedure : ConditionalFormatMinMaxValuesInARow
' Purpose : Setup the conditional formating of the selected cells with the formulas to Max and Minimum values in a row
' Parameter : optional R (Variant) is the Range of the selected cells by code (type range or type string)
' the default value if it is missing or not is valid is the user selection
' usage : ConditionalFormatMinMaxValuesInARow("$C3:$T15")
' Author : Aitor Solozabal Merino - email:aitorsolozabal@gmail.com
' Date : 19/09/2018
' ----------------------------------------------------------------
Sub ConditionalFormatMinMaxValuesInARow(Optional r As Variant)
10 On Error GoTo ConditionalFormatMinMaxValuesInARow_Error
Dim Rango As Range
'check if an argument has been sent
20 If Not IsMissing(r) Then
'there is an argument sent
'check type of the argument
30 If TypeOf r Is Range Then
'It's a range
40 Set Rango = r
50 Else
'It's not a range
60 If TypeName(r) = "String" Then
'It's a string
70 If Len(r) > 4 Then
'is not empty and has 5 characters as minimum (A1:B1)
'then choose string with the address specified as an argument
80 Set Rango = Range(r)
90 Else
'it is empty or not valid then choose user selection
100 Set Rango = Range(Selection.Address)
110 End If
120 Else
'the argument is diferent from a string and from a range and/or is not valid
'it is like empty and then choose user selection
130 Set Rango = Range(Selection.Address)
140 End If
150 End If
160 Else
'it is missing the argument then choose user selection
170 Set Rango = Range(Selection.Address)
180 End If
190 If IsRangeAddressValid(Rango.Address) Then
200 Rango.Select
210 With Selection
'Delete any previous conditional formatting
220 .FormatConditions.Delete
'============================================ MAX VALUE
'add conditional formatting MAX to selected cells
230 .FormatConditions.Add Type:=xlExpression, Formula1:="=" _
& Selection.Cells(1).Address(False, False) _
& "=MAX(" & Rango.Rows(1).Address(False, True) & ")" 'Assigning red color for the conditional formatting MAX
240 .FormatConditions(1).Interior.ColorIndex = 3
250 .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
260 .FormatConditions(1).StopIfTrue = False
'============================================ MIN VALUE
'add conditional formatting MIN to selected cells
270 .FormatConditions.Add Type:=xlExpression, Formula1:="=" _
& Selection.Cells(1).Address(False, False) _
& "=MIN(" & Rango.Rows(1).Address(False, True) & ")" 'Assigning green color for the conditional formatting MIN
280 .FormatConditions(2).Interior.ColorIndex = 4
290 .FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
300 .FormatConditions(2).StopIfTrue = False
310 End With
320 Else
330 MsgBox Rango.Address & " No es un rango valido"
340 End If
350 Range("A1").Select360 On Error GoTo 0
370 Exit Sub
ConditionalFormatMinMaxValuesInARow_Error:
380 MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ConditionalFormatMinMaxValuesInARow, line " & Erl & "."End Sub
'---------------------------------------------------------------------------------------
' Function : IsRangeAddressValid
' return : boolean
' Purpose : check if a range string is valid for process by the ConditionalFormatMinMaxValuesInARow procedure subroutine
' Parameter : Rango:string with the range.address to be checked
' usage : IsRangeAddressValid("$C3:$T15")
' Author : Aitor Solozabal Merino - email:aitorsolozabal@gmail.com
' Date : 19/09/2018
'---------------------------------------------------------------------------------------
'
Function IsRangeAddressValid(Rango As String) As Boolean
Dim n As Integer
Dim a As String
Dim Initial_Column, Initial_Row, Final_Column, Final_Row As String
Dim Dollar_Initial_Column, Dollar_Initial_Row As String
Dim Dollar_Final_Column, Dollar_Final_Row As String
Dim longitud As Integer
Dim x As Variant
Dim dollar As Boolean
10 On Error GoTo IsRangeAddressValid_Error
20 Rango = UCase(Rango)
30 IsRangeAddressValid = True
40 If Len(Rango) > 4 Then
50 a = ""
60 Initial_Column = ""
70 Initial_Row = ""
80 Final_Column = ""
90 Final_Row = ""
100 Dollar_Initial_Column = ""
110 Dollar_Initial_Row = ""
120 Dollar_Final_Column = ""
130 Dollar_Final_Row = ""
140 x = Split(Rango, ":")
150 If (LBound(x) <> UBound(x)) Then
160 dollar = False
170 longitud = Len(x(LBound(x)))
180 For n = 1 To longitud
190 a = Mid(x(LBound(x)), n, 1)
200 If Not dollar And a = "$" Then
210 dollar = True
220 Dollar_Initial_Column = a
230 Else
240 If dollar And a = "$" Then
250 Dollar_Initial_Row = a
260 Else
270 If IsIn(a, "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z") Then
280 Initial_Column = Initial_Column & a
290 Else
300 If IsIn(Val(a), "0,1,2,3,4,5,6,7,8,9") Then
310 Initial_Row = Initial_Row & a
320 End If
330 End If
340 End If
350 End If
360 Next n
370 MsgBox "COLUMNA INICIAL=" & Dollar_Initial_Column & Initial_Column & " FILA INICIAL=" & Dollar_Initial_Row & Initial_Row
380 dollar = False
390 longitud = Len(x(UBound(x)))
400 For n = 1 To longitud
410 a = Mid(x(UBound(x)), n, 1)
420 If Not dollar And a = "$" Then
430 dollar = True
440 Dollar_Final_Column = a
450 Else
460 If dollar And a = "$" Then
470 Dollar_Final_Row = a
480 Else
490 If IsIn(a, "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z") Then
500 Final_Column = Final_Column & a
510 Else
520 If IsIn(Val(a), "0,1,2,3,4,5,6,7,8,9") Then
530 Final_Row = Final_Row & a
540 End If
550 End If
560 End If
570 End If
580 Next n
590 MsgBox "COLUMNA FINAL=" & Dollar_Final_Column & Final_Column & " FILA FINAL=" & Dollar_Final_Row & Final_Row
600 End If
610 End If
620 If Initial_Column < Final_Column Then
630 MsgBox "Columnas validas " & Initial_Column & " es menor que " & Final_Column
640 Else
650 MsgBox "Columnas no validas " & Initial_Column & " no es menor que " & Final_Column
660 IsRangeAddressValid = False
670 End If
680 If Val(Initial_Row) <= Val(Final_Row) Then
690 MsgBox "Filas validas " & Initial_Row & " es menor o igual que " & Final_Row
700 Else
710 MsgBox "Filas no validas " & Initial_Row & " no es menor o igual que " & Final_Row
720 IsRangeAddressValid = False
730 End If
740 On Error GoTo 0
750 Exit Function
IsRangeAddressValid_Error:
760 MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure IsRangeAddressValid, line " & Erl & "."End Function
'---------------------------------------------------------------------------------------
' Function : IsIn
' Return : boolean
' Purpose : Check if a value of a variable is in a set of posible values
' Parameter : valCheck: value to check
' valList : string with values separated by commas
' usage : IsIn(value,"val1,val2,val3,...,valn")
' IsIn(Val(a), "0,1,2,3,4,5,6,7,8,9")
' IsIn(a, "A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z")
' Author : Aitor Solozabal Merino - email:aitorsolozabal@gmail.com
' Date : 19/09/2018
'---------------------------------------------------------------------------------------
'
Function IsIn(valCheck, valList As String) As Boolean
10 On Error GoTo IsIn_Error
20 IsIn = Not InStr("," & valList & ",", "," & valCheck & ",") = 030 On Error GoTo 0
40 Exit Function
IsIn_Error:
50 MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure IsRangeAddressValid, line " & Erl & "."End Function
Comentarios sobre la versión: 1.0 (0)
No hay comentarios