Extraer grupos de iguales

Hola Fernando:
No se si a los demas les funciona, pero a mi me va de perlas. Muy bueno el codigo de filtrado.
Saludos y gracias por compartir


"Fernando Arroyo" escribió en el mensaje news:%
"Jose" escribió en el mensaje news:

Fernando muchisimas gracias:
Esta tarde lo probare y te dire como me funciona.
Saludos :-)))

Me anticipo a tu prueba: tal como está el código, no te va a funcionar bien. Tienes que sustituir la instrucción

For lngAcum = 1 To UBound(m2)

por

For lngAcum = 1 To 20


Ten en cuenta que esto implica que para cambiar el número máximo de veces consecutivas que puede estar un elemento habría que modificar tanto esta instrucción como la que decía en mi anterior mensaje. El código completo (y creo que, ahora sí, funcionando bien), es:


Sub Prueba()
Dim m1() As Long, m2() As Long
Dim rngF As Range, rngC As Range
Dim n As Long, lngAcum As Long, lngValor As Long, strC As String

With Worksheets("Hoja1")
.Range("A1:A" & .[A65536].End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

Set rngF = .Range("A2:A" & .[A65536].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
ReDim m1(1 To rngF.Count)
ReDim m2(1 To rngF.Count, 20) '20 es el número máximo de veces consecutivas de un número que puede haber.

n = 1
For Each rngC In rngF
m1(n) = rngC
n = n + 1
Next rngC

.ShowAllData

n = 3
lngValor = .[A2]
lngAcum = 1

While Not IsEmpty(.Cells(n, 1))
If .Cells(n, 1) = lngValor Then
lngAcum = lngAcum + 1
Else
If lngAcum > 1 Then m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) = m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) + 1
lngAcum = 1
lngValor = .Cells(n, 1)
End If

n = n + 1

Wend

End With

If lngAcum > 1 Then m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) = m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) + 1

For n = 1 To UBound(m1)
For lngAcum = 1 To 20 '20 es el número máximo de veces consecutivas de un número que puede haber.
If m2(n, lngAcum) > 0 Then strC = strC & m1(n) & " - " & m2(n, lngAcum) & IIf(m2(n, lngAcum) = 1, " grupo", " grupos") & " de " & lngAcum & " repeticiones" & vbNewLine
Next lngAcum
Next n

MsgBox strC

Set rngC = Nothing
Set rngF = Nothing
End Sub


Un saludo.


Fernando Arroyo
MS MVP - Excel

Eres un monstruo del Excel.
La macro funciona a la perfeccion.
Gracias por todo Fernando

Fernando Arroyo escribió en el mensaje de noticias #
"Jose" escribió en el mensaje news:

Fernando muchisimas gracias:
Esta tarde lo probare y te dire como me funciona.
Saludos :-)))

Me anticipo a tu prueba: tal como está el código, no te va a funcionar bien. Tienes que sustituir la instrucción

For lngAcum = 1 To UBound(m2)

por

For lngAcum = 1 To 20


Ten en cuenta que esto implica que para cambiar el número máximo de veces consecutivas que puede estar un elemento habría que modificar tanto esta instrucción como la que decía en mi anterior mensaje. El código completo (y creo que, ahora sí, funcionando bien), es:


Sub Prueba()
Dim m1() As Long, m2() As Long
Dim rngF As Range, rngC As Range
Dim n As Long, lngAcum As Long, lngValor As Long, strC As String

With Worksheets("Hoja1")
.Range("A1:A" & .[A65536].End(xlUp).Row).AdvancedFilter Action:=xlFilterInPlace, Unique:=True

Set rngF = .Range("A2:A" & .[A65536].End(xlUp).Row).SpecialCells(xlCellTypeVisible)
ReDim m1(1 To rngF.Count)
ReDim m2(1 To rngF.Count, 20) '20 es el número máximo de veces consecutivas de un número que puede haber.

n = 1
For Each rngC In rngF
m1(n) = rngC
n = n + 1
Next rngC

.ShowAllData

n = 3
lngValor = .[A2]
lngAcum = 1

While Not IsEmpty(.Cells(n, 1))
If .Cells(n, 1) = lngValor Then
lngAcum = lngAcum + 1
Else
If lngAcum > 1 Then m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) = m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) + 1
lngAcum = 1
lngValor = .Cells(n, 1)
End If

n = n + 1

Wend

End With

If lngAcum > 1 Then m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) = m2(WorksheetFunction.Match(lngValor, m1, 0), lngAcum) + 1

For n = 1 To UBound(m1)
For lngAcum = 1 To 20 '20 es el número máximo de veces consecutivas de un número que puede haber.
If m2(n, lngAcum) > 0 Then strC = strC & m1(n) & " - " & m2(n, lngAcum) & IIf(m2(n, lngAcum) = 1, " grupo", " grupos") & " de " & lngAcum & " repeticiones" & vbNewLine
Next lngAcum
Next n

MsgBox strC

Set rngC = Nothing
Set rngF = Nothing
End Sub


Un saludo.


Fernando Arroyo
MS MVP - Excel

Gracias a vosotros, Seti y Jose. Me alegra saber que el código os ha sido de utilidad :-)
Un saludo.


Fernando