...mejor aun este:
'---------Inicio Codigo---------
Sub SacarValoresRepetidos()
Dim Valores As Variant
Dim ValoresUnicos As Variant
Dim Hoja As Worksheet
Dim HojaInicial As Worksheet
Dim HojaExtracto As Worksheet
Dim RangoExtracto As Range
Dim RangoBaseDeDatos As String
Dim Celda As Range
Dim Cnt As Single
Dim Ocurrencias As Single
With ThisWorkbook
Set HojaExtracto = .Worksheets("repetidos")
Set RangoExtracto = HojaExtracto.Range("A1")
RangoBaseDeDatos = "A1:D3000"
Set HojaInicial = .ActiveSheet
Application.ScreenUpdating = False
RangoExtracto.CurrentRegion.ClearContents
ReDim Valores(0)
For Each Hoja In .Worksheets
If Hoja.Name <> HojaExtracto.Name Then
For Each Celda In Hoja.Range(RangoBaseDeDatos)
Valores(UBound(Valores)) = Celda.Value
ReDim Preserve Valores(UBound(Valores) + 1)
Next Celda
End If
Next Hoja
ValoresUnicos = UniqueItems(Valores, False)
For i = LBound(ValoresUnicos) To UBound(ValoresUnicos)
For Each Hoja In .Worksheets
If Not Hoja Is HojaExtracto Then
Ocurrencias = Ocurrencias + _
WorksheetFunction.CountIf(Hoja. _
Range(RangoBaseDeDatos), _
ValoresUnicos(i))
End If
Next Hoja
If ValoresUnicos(i) <> "" And Ocurrencias > 1 Then
RangoExtracto.Offset(Cnt, 0) = ValoresUnicos(i)
RangoExtracto.Offset(Cnt, 1) = Ocurrencias
Cnt = Cnt + 1
End If
Ocurrencias = 0
Next i
HojaExtracto.Activate
On Error GoTo errHandler
RangoExtracto.CurrentRegion.Sort Key1:=Range("A1"), _
Order1:=xlAscending
End With
Exit Sub
errHandler:
MsgBox "No se han detectado valores repetidos."
HojaInicial.Activate
End Sub
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' cnt for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i
AddItem:
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
'---------Fin Codigo---------
Post by unknownRaul,
prueba este codigo.
Saludos,
KL
'---------Inicio Codigo---------
Sub SacarValoresRepetidos()
Dim Valores As Variant
Dim ValoresUnicos As Variant
Dim Hoja As Worksheet
Dim HojaInicial As Worksheet
Dim HojaExtracto As Worksheet
Dim RangoExtracto As Range
Dim RangoBaseDeDatos As String
Dim Celda As Range
Dim Cnt As Single
Dim Ocurrencias As Single
Set HojaExtracto = ThisWorkbook.Worksheets("Hoja1")
Set RangoExtracto = HojaExtracto.Range("A1")
Set HojaInicial = ActiveSheet
RangoBaseDeDatos = "A1:D3000"
RangoExtracto.CurrentRegion.ClearContents
Application.ScreenUpdating = False
ReDim Valores(0)
For Each Hoja In ThisWorkbook.Sheets
If Hoja.Name <> HojaExtracto.Name Then
For Each Celda In Hoja.Range(RangoBaseDeDatos)
Valores(UBound(Valores)) = Celda.Value
ReDim Preserve Valores(UBound(Valores) + 1)
Next Celda
End If
Next Hoja
ValoresUnicos = UniqueItems(Valores, False)
For i = LBound(ValoresUnicos) To UBound(ValoresUnicos)
If ValoresUnicos(i) <> "" Then
For Each Hoja In ThisWorkbook.Sheets
If Hoja.Name <> HojaExtracto.Name Then
Ocurrencias = Ocurrencias + _
WorksheetFunction.CountIf(Hoja. _
Range(RangoBaseDeDatos), _
ValoresUnicos(i))
End If
Next Hoja
RangoExtracto.Offset(Cnt, 0) = ValoresUnicos(i)
RangoExtracto.Offset(Cnt, 1) = Ocurrencias
Ocurrencias = 0
Cnt = Cnt + 1
End If
Next i
HojaExtracto.Activate
RangoExtracto.CurrentRegion.Sort Key1:=Range("A1"), _
Order1:=xlAscending
HojaInicial.Activate
End Sub
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
' Accepts an array or range as input
' If Count = True or is missing, the function returns the number
' of unique elements
' If Count = False, the function returns a variant array of unique
' elements
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
' If 2nd argument is missing, assign default value
If IsMissing(Count) Then Count = True
' cnt for number of unique elements
NumUnique = 0
' Loop thru the input array
For Each Element In ArrayIn
FoundMatch = False
' Has item been added yet?
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i
' If not in list, add the item to unique list
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
' Assign a value to the function
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
'---------Fin Codigo---------
Post by KLRaul,
Tienes razon - no funciona. Voy a ver si se me ocurre otra cosa.
KL
Post by Raúl Z.Hola nuevamente KL
Haciendo nuevas pruebas, descubro que si repito numeros en la primera hoja
del libro si me los expone en "repetidos", no se como hacer para las
demas.
Gracias
Post by unknownRaul,
Seguramente hay una solucion mas elegante y mas facil, pero por si te urge,
he escrito el codigo de abajo. Que conste q lo hice en la oficina a marchas
forzadas para poder salir cuanto antes, por lo cual no prestE mucha atencion
a la forma sino al resultado. El codigo es largo - asegurate de copiarlo
todo, crear un nuevo modulo (digamos Modulo1) desde el editor VBA y pegarlo
todo ahi. Puedes asignar el macro a un boton o llamarlo desde el menu
Herramientas>Macro>Macros o tecleando Alt+F8. Tambien dentro del codigo
tendras q modificar el nombre de la hoja en la q apareceria el extracto, el
rango que contiene los valores a evaluar y posiblemente anadir mas hojas a
excluir de la evaluacion. Acuerdate de hacer backup de tu fichero antes de
usar el macro. Si hay algun problema comentalo aqui. Me imagino q ya vendran
soluciones mejores.
Un saludo,
KL
'---------Inicio Codigo---------
Sub SacarValoresRepetidos()
Dim MisHojas As Variant
Dim MisValores As Variant
Dim Contador As Single
'Congelamos la pantalla.
Application.ScreenUpdating = False
With ThisWorkbook
'Borramos la lista anterior.
.Sheets("Sheet1").Range("A1").CurrentRegion.ClearContents
'Creamos la lista de hojas a evaluar incluyendo
'todas las hojas menos la Sheet1.
ReDim MisHojas(0)
For Each hoja In .Worksheets
If hoja.Name <> "Sheet1" Then
MisHojas(UBound(MisHojas)) = hoja.Name
ReDim Preserve MisHojas(UBound(MisHojas) + 1)
End If
Next hoja
ReDim Preserve MisHojas(UBound(MisHojas) - 1)
'Seleccionamos las hojas y el rango a evaluar
'para poder usarlos como un rango unico.
Worksheets(MisHojas).Select
Range("A1:C30").Select
'Usando la funcion de John Walkenbach
'sacamos la lista de valores unicos.
MisValores = UniqueItems(Selection, False)
'Pasamos la lista de valores unicos a
'la hoja Sheet1 omitiendo los q no se
'repiten o son iguales a "".
For i = LBound(MisValores) To UBound(MisValores)
If WorksheetFunction.CountIf(Selection, MisValores(i)) > 1 _
And MisValores(i) <> "" Then
With .Worksheets("Sheet1")
.Cells(Contador + 1, 1) = MisValores(i)
.Cells(Contador + 1, 2) = WorksheetFunction. _
CountIf(Selection, MisValores(i))
Contador = Contador + 1
End With
End If
Next i
'Quitamos la seleccion del rango evaluado,
'deselcionamos las hojas y aprovechamos para
'volver a la hoja Sheet1.
Range("A1").Select
.Sheets("Sheet1").Select
'Ordenamos el extracto en orden descendiente
Range("A1").CurrentRegion.Sort Key1:=Range("A1"), _
Order1:=xlAscending
End With
End Sub
Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant
Dim Unique() As Variant ' array that holds the unique items
Dim Element As Variant
Dim i As Integer
Dim FoundMatch As Boolean
If IsMissing(Count) Then Count = True
NumUnique = 0
For Each Element In ArrayIn
FoundMatch = False
For i = 1 To NumUnique
If Element = Unique(i) Then
FoundMatch = True
GoTo AddItem '(Exit For-Next loop)
End If
Next i
If Not FoundMatch Then
NumUnique = NumUnique + 1
ReDim Preserve Unique(NumUnique)
Unique(NumUnique) = Element
End If
Next Element
If Count Then UniqueItems = NumUnique Else UniqueItems = Unique
End Function
'---------Fin Codigo---------
Post by Raúl Z.Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con numeros x
ej.
A B C D
1 28 32 11 9
2 36 75 8 54
3 33 43 6 32
4 29 98 5 28
5 43 77 63 88
6 11 84 13 15
Como puedo hacer para informar en una hoja distinta los numero repetidos,
o
A
1 28
2 32
3 11
etc.etc.
Muchas gracias
Raul