Resaltar automáticamente valores que se repitan n veces en Excel, si son = n; < n ; <=n ; >= n ; > n
📌Con Programación Fija
Una vez que hallamos definido nuestro requerimiento, es decir que se resalten los valores:
1️⃣ Iguales al número de veces requerido, = n
2️⃣ Menores al número de veces requerido, < n
3️⃣ Menores o iguales al número de veces requerido, <= n
4️⃣ Mayores o iguales al número de veces requerido, >= n
5️⃣ Mayores al número de veces requerido, > n
Para este caso se busca resaltar los valores que se repiten = 3
Los datos se encuentran en el rango B7:N15
🕐Abrir el editor de Visual Basic.
Posicionarse en el nombre de la hoja, clic derecho, opción "Ver código"
🕑Copiar y Pegar el siguiente Código
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, N As Integer, Cld As Range, Vlr As Variant, Clr As Long, Vnctrd As Boolean, VR As Object, L As Range
Set Rng = Range("B7:N15")
N = 3
If Not Intersect(Target, Rng) Is Nothing Then
Set VR = CreateObject("Scripting.Dictionary")
For Each Cld In Rng.Cells
Vlr = Cld.Value
If Vlr <> "" And Application.WorksheetFunction.CountIf(Rng, Vlr) = N Then
Vnctrd = True
If Not VR.Exists(Vlr) Then
Clr = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
VR.Add Vlr, Clr
End If
Clr = VR(Vlr)
Cld.Interior.Color = Clr
ElseIf Cld.Interior.ColorIndex <> xlNone Then
If L Is Nothing Then
Set L = Cld
Else
Set L = Union(L, Cld)
End If
End If
Next Cld
If Not L Is Nothing Then
L.Interior.ColorIndex = xlNone
End If
End If
End Sub
🕒Guardar como: Libro de Excel habilitado para macros
Clic en el icono de guardar, clic en "No"
Desplegar la lista de opciones para tipo, seleccionar Libro de Excel habilitado para macros y Guardar
✔Listo
Los valores que se repiten exactamente 3 veces se resaltaran automáticamente, cada vez que se añada o cambie datos dentro del rango establecido
Como emplear cuando lo que se busca es: < n ; <=n ; >= n ; > n
🎮 Con Programación Dinámica
Código a emplear:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, S As Variant, N As Integer, Cld As Range, Vlr As Variant, Clr As Long, Vnctrd As Boolean, VR As Object, L As Range
Set Rng = Range(Range("M5").Value)
S = Range("H5").Value
N = Range("J5").Value
If Not Intersect(Target, Union(Rng, Range("M5"), Range("H5"), Range("J5"))) Is Nothing Then
Set VR = CreateObject("Scripting.Dictionary")
For Each Cld In Rng.Cells
Vlr = Cld.Value
Select Case S
Case 1
If Vlr <> "" And Application.WorksheetFunction.CountIf(Rng, Vlr) = N Then
Vnctrd = True
If Not VR.Exists(Vlr) Then
Clr = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
VR.Add Vlr, Clr
End If
Clr = VR(Vlr)
Cld.Interior.Color = Clr
ElseIf Cld.Interior.ColorIndex <> xlNone Then
If L Is Nothing Then
Set L = Cld
Else
Set L = Union(L, Cld)
End If
End If
Case 2
If Vlr <> "" And Application.WorksheetFunction.CountIf(Rng, Vlr) < N Then
Vnctrd = True
If Not VR.Exists(Vlr) Then
Clr = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
VR.Add Vlr, Clr
End If
Clr = VR(Vlr)
Cld.Interior.Color = Clr
ElseIf Cld.Interior.ColorIndex <> xlNone Then
If L Is Nothing Then
Set L = Cld
Else
Set L = Union(L, Cld)
End If
End If
Case 3
If Vlr <> "" And Application.WorksheetFunction.CountIf(Rng, Vlr) <= N Then
Vnctrd = True
If Not VR.Exists(Vlr) Then
Clr = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
VR.Add Vlr, Clr
End If
Clr = VR(Vlr)
Cld.Interior.Color = Clr
ElseIf Cld.Interior.ColorIndex <> xlNone Then
If L Is Nothing Then
Set L = Cld
Else
Set L = Union(L, Cld)
End If
End If
Case 4
If Vlr <> "" And Application.WorksheetFunction.CountIf(Rng, Vlr) >= N Then
Vnctrd = True
If Not VR.Exists(Vlr) Then
Clr = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
VR.Add Vlr, Clr
End If
Clr = VR(Vlr)
Cld.Interior.Color = Clr
ElseIf Cld.Interior.ColorIndex <> xlNone Then
If L Is Nothing Then
Set L = Cld
Else
Set L = Union(L, Cld)
End If
End If
Case 5
If Vlr <> "" And Application.WorksheetFunction.CountIf(Rng, Vlr) > N Then
Vnctrd = True
If Not VR.Exists(Vlr) Then
Clr = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
VR.Add Vlr, Clr
End If
Clr = VR(Vlr)
Cld.Interior.Color = Clr
ElseIf Cld.Interior.ColorIndex <> xlNone Then
If L Is Nothing Then
Set L = Cld
Else
Set L = Union(L, Cld)
End If
End If
End Select
Next Cld
If Not Vnctrd Then
MsgBox "No se encontró ningún valor que se repita " & IIf(S = 1, "", IIf(S = 2, "menos de ", IIf(S = 3, "menos o igual a ", IIf(S = 4, "más o igual a ", IIf(S = 5, "más de ", ""))))) & N & IIf(N = 1, " vez", " veces") & "."
ElseIf VR.Count = 1 Then
MsgBox "Se encontró " & VR.Count & " valor que se repite " & IIf(S = 1, "", IIf(S = 2, "menos de ", IIf(S = 3, "menos o igual a ", IIf(S = 4, "más o igual a ", IIf(S = 5, "más de ", ""))))) & N & IIf(N = 1, " vez", " veces") & "."
Else
MsgBox "Se encontraron " & VR.Count & " valores que se repiten " & IIf(S = 1, "", IIf(S = 2, "menos de ", IIf(S = 3, "menos o igual a ", IIf(S = 4, "más o igual a ", IIf(S = 5, "más de ", ""))))) & N & IIf(N = 1, " vez", " veces") & "."
End If
If Not L Is Nothing Then
L.Interior.ColorIndex = xlNone
End If
End If
End Sub
Comentarios
Publicar un comentario