Código de Visual Basic para Aplicaciones - Formato Condicional para Maximo y Minimo en cada fila del rango seleccionado

Imágen de perfil
Val: 16
Ha disminuido 1 puesto en Visual Basic para Aplicaciones (en relación al último mes)
Gráfica de Visual Basic para Aplicaciones

Formato Condicional para Maximo y Minimo en cada fila del rango seleccionadográfica de visualizaciones


Visual Basic para Aplicaciones

Actualizado el 23 de Octubre del 2018 por Aitor (Publicado el 20 de Septiembre del 2018)
1.776 visualizaciones desde el 20 de Septiembre del 2018
ConditionalFormatingMinMaxValuesInARow
Codigo de macro en VBA para Excel que realiza el formato condicional en un rango de celdas seleccionadas por programa o por la selección del usuario antes de llamar a la macro.
El formato condicional consiste en realzar las celdas con el valor minimo (relleno en verde) y maximo (relleno en rojo) por cada fila según se muestra en la imagen.
En la imagen se ha seleccionado el rango de celdas D5:L22 y luego se ha ejecutado la macro.

Requerimientos

Microsoft Excel

1.0

Publicado el 20 de Septiembre del 2018gráfica de visualizaciones de la versión: 1.0
790 visualizaciones desde el 20 de Septiembre del 2018
estrellaestrellaestrellaestrellaestrella
estrellaestrellaestrellaestrella
estrellaestrellaestrella
estrellaestrella
estrella

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
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").Select
360 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 & ",") = 0
30  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
 

Comentar la versión: 1.0

Nombre
Correo (no se visualiza en la web)
Valoración
Comentarios
Es necesario revisar y aceptar las políticas de privacidad

1.1

Publicado el 23 de Octubre del 2018gráfica de visualizaciones de la versión: 1.1
987 visualizaciones desde el 23 de Octubre del 2018
http://lwp-l.com/s4829