(demasiado antiguo para responder)
Números repetidos
Raúl Z.
2004-12-21 16:27:03 UTC
Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con números 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 número repetidos, o
sea que siguiendo el ej. anterior me diga:

A
1 28
2 32
3 11

etc.etc.
Muchas gracias
Raúl
"KL" <lapink2000(at)hotmail.com>
2004-12-21 19:26:37 UTC
Raul,

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

AddItem:
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
Raúl Z.
2004-12-21 21:43:05 UTC
Hola KL
Muchas gracias x atender mi respuesta.
Te cuento los pasos q realicé:
El libro tiene las hojas llamadas x ej. "pepe" "pipo" "popo" etc. y cree
otra llamada "repetidos", cambié todo lo que en el codigo decia "sheet1" x
"repetido" bien.
amplie el rango en
Range("A1:C30").Select
y puse el que realmente va que es = en todas las hojas.

Como resultado y a pesar de tener número repetido en varias hojas la macro
termina en "repetido", pero vacía.

Me falta algo?

Gracias.
Post by "KL" <lapink2000(at)hotmail.com>
Raul,
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
Raúl Z.
2004-12-21 21:55:03 UTC
Hola nuevamente KL
Haciendo nuevas pruebas, descubro que si repito números en la primera hoja
del libro si me los expone en "repetidos", no se como hacer para las demás.
Gracias
Post by "KL" <lapink2000(at)hotmail.com>
Raul,
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
KL
2004-12-21 23:16:13 UTC
Raul,

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 "KL" <lapink2000(at)hotmail.com>
Raul,
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
"KL" <lapink2000(at)hotmail.com>
2004-12-21 23:57:18 UTC
Raul,

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

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 KL
Raul,
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 "KL" <lapink2000(at)hotmail.com>
Raul,
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
KL
2004-12-22 00:59:51 UTC
...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 "KL" <lapink2000(at)hotmail.com>
Raul,
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 KL
Raul,
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 "KL" <lapink2000(at)hotmail.com>
Raul,
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
Luis Garcia
2004-12-22 11:00:01 UTC
Post by Raúl Z.
Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con números x
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 número repetidos,
A
1 28
2 32
3 11
Hola Raul: Como estoy aprendiendo a usar formulas matriciales, he probado y
he conseguido 'algo' que hace algo parecido a lo que buscas, a ver si te
sirve:

Suposicion:, los número están comprendidos entre 1 y 99
NOTA: Selecciona 100 celdas en columna (p.e. F1:F99) y
escribe lo siguiente en la barra de formulas, finalizando con
MAYUS-CTRL-INTRO:

=K.ESIMO.MAYOR(
(CONTAR.SI($A$1:$D$6; FILA(INDIRECTO("1:99"))) > 0)
* FILA(INDIRECTO("1:99"));
FILA(INDIRECTO("1:99")))

Saludos y suerte
"KL" <lapink2000(at)hotmail.com>
2004-12-22 11:31:34 UTC
Luis,

Esta formula es buena para extraer valores repetidos dentro de una sola
hoja. Creo q el problema es un poco mas complejo debido a que hay que
detectar repeticiones no solo (?no tanto?) dentro de una hoja sino tambien
atraves de 19 hojas mas.

Saludos,
KL
Post by Luis Garcia
Post by Raúl Z.
Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con números x
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 número repetidos,
A
1 28
2 32
3 11
Hola Raul: Como estoy aprendiendo a usar formulas matriciales, he probado y
he conseguido 'algo' que hace algo parecido a lo que buscas, a ver si te
Suposicion:, los número están comprendidos entre 1 y 99
NOTA: Selecciona 100 celdas en columna (p.e. F1:F99) y
escribe lo siguiente en la barra de formulas, finalizando con
=K.ESIMO.MAYOR(
(CONTAR.SI($A$1:$D$6; FILA(INDIRECTO("1:99"))) > 0)
* FILA(INDIRECTO("1:99"));
FILA(INDIRECTO("1:99")))
Saludos y suerte
Luis Garcia
2004-12-22 12:14:54 UTC
"KL" <lapink2000(at)hotmail.com> escribió en...
Post by "KL" <lapink2000(at)hotmail.com>
Luis,
Esta formula es buena para extraer valores repetidos dentro de una sola
hoja. Creo q el problema es un poco mas complejo debido a que hay que
detectar repeticiones no solo (?no tanto?) dentro de una hoja sino tambien
atraves de 19 hojas mas.
Si la formula le sirve, entonces en una hoja nueva copias la formula en las
columnas "1-20" para las 20 hojas (cambiando la referencia de los datos)
y en la columna 22, vuelves a copiar la formula, pero referenciando a las
columnas "1-20" de esta nueva hoja...

.... eso si, no me responsabilizo del tiempo que tarde en calcularlo todo,
yo solamente estaba aprovechando para practicar con formulas
matriciales :-))))

Saludos
KL
2004-12-22 12:32:52 UTC
Raul,

Una solucion podria ser la de montar un hoja intermedia q podria ser algo
asi:
[A] [B] [C] [:] [T] [U]
[1] Valor Hoja1 Hoja2 Hoja: Hoja20 Total
[2] 1 0 0 : 0 0
[3] 2 1 0 : 0 1
[4] 3 0 1 : 0 1
[...] : : : : : 0
[100] 99 0 0 : 0 0


En la celda [B2] introduces la siguiente formula y la copias arrastrando
horizontal y verticalmente hasta la [T100]:

=CONTAR.SI(INDIRECTO("'"&C$2&"'!$A$1:$D$3000"),$B3)

En la celda [U2] pones la suma de la fila y la arrastras hacia abajo hasta
la celda [U100]:

=SUMA($B3:$T3)

Finalmente usas la formula q propone Luis, pero ligeramente modificada:

=K.ESIMO.MAYOR((DESREF($A$2:$A$100, 0,20) > 1)*FILA(INDIRECTO("1:99")),
FILA(INDIRECTO("1:99")))

Para introducir esta formula selecciona 100 celdas verticalmente pon el
cursor dentro de la primera celda pega la formula y pulsa MAYUS-CTRL-INTRO

Saludos,
KL
Post by "KL" <lapink2000(at)hotmail.com>
Luis,
Esta formula es buena para extraer valores repetidos dentro de una sola
hoja. Creo q el problema es un poco mas complejo debido a que hay que
detectar repeticiones no solo (?no tanto?) dentro de una hoja sino tambien
atraves de 19 hojas mas.
Saludos,
KL
Post by Luis Garcia
Post by Raúl Z.
Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con números x
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 número repetidos,
A
1 28
2 32
3 11
Hola Raul: Como estoy aprendiendo a usar formulas matriciales, he probado y
he conseguido 'algo' que hace algo parecido a lo que buscas, a ver si te
Suposicion:, los número están comprendidos entre 1 y 99
NOTA: Selecciona 100 celdas en columna (p.e. F1:F99) y
escribe lo siguiente en la barra de formulas, finalizando con
=K.ESIMO.MAYOR(
(CONTAR.SI($A$1:$D$6; FILA(INDIRECTO("1:99"))) > 0)
* FILA(INDIRECTO("1:99"));
FILA(INDIRECTO("1:99")))
Saludos y suerte
KL
2004-12-22 12:38:58 UTC
Luis,

En este situacion (si se quiere montar toda una matriz intermedia) bastaria
con una simple combinacion de CONTAR.SI e INDIRECTO para contar los valores
repetidos y luego usar una formula matricial en la columna 22 (mira mi
ultimo posting mas arriba)

Saludos,
KL
Post by Luis Garcia
"KL" <lapink2000(at)hotmail.com> escribió en...
Post by "KL" <lapink2000(at)hotmail.com>
Luis,
Esta formula es buena para extraer valores repetidos dentro de una sola
hoja. Creo q el problema es un poco mas complejo debido a que hay que
detectar repeticiones no solo (?no tanto?) dentro de una hoja sino tambien
atraves de 19 hojas mas.
Si la formula le sirve, entonces en una hoja nueva copias la formula en las
columnas "1-20" para las 20 hojas (cambiando la referencia de los datos)
y en la columna 22, vuelves a copiar la formula, pero referenciando a las
columnas "1-20" de esta nueva hoja...
.... eso si, no me responsabilizo del tiempo que tarde en calcularlo todo,
yo solamente estaba aprovechando para practicar con formulas
matriciales :-))))
Saludos
Daniel.M
2004-12-22 15:14:58 UTC
Hola Raul,

Tiene que tener una hoja que se llama "HojarSumar" para inscribir los
resultados.
La macro siguiente monstra las duplicadas (pero no los errores o celdas vacias).
Puede cambiar el rango (evidamente).


Sub BuscarDuplicadasVariasHojas()
Dim Hoja As Worksheet, C As Range
Dim D As Object, Llaves As Variant, Veces As Variant
Dim res As Variant ' resultado de Match()

Worksheets("HojaSumar").Range("A2:B10000").ClearContents

Set D = CreateObject("Scripting.Dictionary")

For Each Hoja In ThisWorkbook.Worksheets
If Hoja.Name <> "HojaSumar" Then
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambiar el rango si lo quiere
If Not IsError(C.Value) Then ' sin error
If C.Value <> "" Then ' sin vacias
If D.Exists(C.Value) Then
D.Item(C.Value) = D.Item(C.Value) + 1
Else
D.Add C.Value, 1
End If
End If
End If
Next C
End If
Next Hoja

Llaves = D.Keys
Veces = D.Items

'Monstrar resultados
With Worksheets("HojaSumar").Range("A2").Resize(D.Count)
.Value = Application.Transpose(Llaves)
.Offset(0, 1).Value = Application.Transpose(Veces)
.Resize(, 2).Sort key1:=.Cells(1, 2), order1:=xlDescending
res = Application.Match(1, .Offset(0, 1), 0)
If Not IsError(res) Then
.Offset(res - 1, 0).Resize(, 2).ClearContents
End If
End With

Set D = Nothing

End Sub


Saludos,

Daniel M.
Post by Raúl Z.
Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con números 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 número repetidos, o
A
1 28
2 32
3 11
etc.etc.
Muchas gracias
Raúl
"KL" <lapink2000(at)hotmail.com>
2004-12-22 15:41:03 UTC
Daniel,

Excelente idea - me encanta. Y es super rapida.

Saludos,
KL
Post by Daniel.M
Hola Raul,
Tiene que tener una hoja que se llama "HojarSumar" para inscribir los
resultados.
La macro siguiente monstra las duplicadas (pero no los errores o celdas vacias).
Puede cambiar el rango (evidamente).
Sub BuscarDuplicadasVariasHojas()
Dim Hoja As Worksheet, C As Range
Dim D As Object, Llaves As Variant, Veces As Variant
Dim res As Variant ' resultado de Match()
Worksheets("HojaSumar").Range("A2:B10000").ClearContents
Set D = CreateObject("Scripting.Dictionary")
For Each Hoja In ThisWorkbook.Worksheets
If Hoja.Name <> "HojaSumar" Then
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambiar el rango si lo quiere
If Not IsError(C.Value) Then ' sin error
If C.Value <> "" Then ' sin vacias
If D.Exists(C.Value) Then
D.Item(C.Value) = D.Item(C.Value) + 1
Else
D.Add C.Value, 1
End If
End If
End If
Next C
End If
Next Hoja
Llaves = D.Keys
Veces = D.Items
'Monstrar resultados
With Worksheets("HojaSumar").Range("A2").Resize(D.Count)
.Value = Application.Transpose(Llaves)
.Offset(0, 1).Value = Application.Transpose(Veces)
.Resize(, 2).Sort key1:=.Cells(1, 2), order1:=xlDescending
res = Application.Match(1, .Offset(0, 1), 0)
If Not IsError(res) Then
.Offset(res - 1, 0).Resize(, 2).ClearContents
End If
End With
Set D = Nothing
End Sub
Saludos,
Daniel M.
Post by Raúl Z.
Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con números 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 número repetidos, o
A
1 28
2 32
3 11
etc.etc.
Muchas gracias
Raúl
Daniel.M
2004-12-23 01:02:11 UTC
Post by "KL" <lapink2000(at)hotmail.com>
Excelente idea - me encanta. Y es super rapida.
Saludos,
KL
:-)
Gracias KL.

Daniel M.
Raúl Z.
2004-12-27 10:14:14 UTC
Hola Daniel,
Muchas Gracias
Tu código me parece bastante interesante, lo estoy probando, al igual que el
de Daniel, después veré por cual me decido, ambos funcionan, aunque tengo que
hacerle algunos retoques.
Alguno de ellos es eliminar de la búsqueda determinadas hojas, x ej. la hoja
"Perez" la hoja "Sanchez" etc. tendría que ir aquí no?
If Hoja.Name <> "HojaSumar" Then

Espero tu amable respuesta
Muchas Gracias.
Raúl
Post by Daniel.M
Hola Raul,
Tiene que tener una hoja que se llama "HojarSumar" para inscribir los
resultados.
La macro siguiente monstra las duplicadas (pero no los errores o celdas vacias).
Puede cambiar el rango (evidamente).
Sub BuscarDuplicadasVariasHojas()
Dim Hoja As Worksheet, C As Range
Dim D As Object, Llaves As Variant, Veces As Variant
Dim res As Variant ' resultado de Match()
Worksheets("HojaSumar").Range("A2:B10000").ClearContents
Set D = CreateObject("Scripting.Dictionary")
For Each Hoja In ThisWorkbook.Worksheets
If Hoja.Name <> "HojaSumar" Then
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambiar el rango si lo quiere
If Not IsError(C.Value) Then ' sin error
If C.Value <> "" Then ' sin vacias
If D.Exists(C.Value) Then
D.Item(C.Value) = D.Item(C.Value) + 1
Else
D.Add C.Value, 1
End If
End If
End If
Next C
End If
Next Hoja
Llaves = D.Keys
Veces = D.Items
'Monstrar resultados
With Worksheets("HojaSumar").Range("A2").Resize(D.Count)
.Value = Application.Transpose(Llaves)
.Offset(0, 1).Value = Application.Transpose(Veces)
.Resize(, 2).Sort key1:=.Cells(1, 2), order1:=xlDescending
res = Application.Match(1, .Offset(0, 1), 0)
If Not IsError(res) Then
.Offset(res - 1, 0).Resize(, 2).ClearContents
End If
End With
Set D = Nothing
End Sub
Saludos,
Daniel M.
Post by Raúl Z.
Hola a todos
Tengo un libro con 20 hojas y en cada hoja tengo 4 columnas con números 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 número repetidos, o
A
1 28
2 32
3 11
etc.etc.
Muchas gracias
Raúl
Raúl Z.
2004-12-27 10:21:03 UTC
Muchas gracias KL, estoy probando lo tuyo y lo de Daniel M., las 2 funcionan,
pero la de Daniel M. es menos compleja y más simple me parece.
Gracias x tu interés.

Raúl
Post by "KL" <lapink2000(at)hotmail.com>
'---------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
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
' 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 "KL" <lapink2000(at)hotmail.com>
Raul,
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 KL
Raul,
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 "KL" <lapink2000(at)hotmail.com>
Raul,
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
Raúl Z.
2004-12-27 10:23:03 UTC
Muchas Gracias Luis.

Raúl
Post by Luis Garcia
"KL" <lapink2000(at)hotmail.com> escribió en...
Post by "KL" <lapink2000(at)hotmail.com>
Luis,
Esta formula es buena para extraer valores repetidos dentro de una sola
hoja. Creo q el problema es un poco mas complejo debido a que hay que
detectar repeticiones no solo (?no tanto?) dentro de una hoja sino tambien
atraves de 19 hojas mas.
Si la formula le sirve, entonces en una hoja nueva copias la formula en las
columnas "1-20" para las 20 hojas (cambiando la referencia de los datos)
y en la columna 22, vuelves a copiar la formula, pero referenciando a las
columnas "1-20" de esta nueva hoja...
..... eso si, no me responsabilizo del tiempo que tarde en calcularlo todo,
yo solamente estaba aprovechando para practicar con formulas
matriciales :-))))
Saludos
KL
2004-12-27 10:41:50 UTC
Raul,

Prueba la estructura de abajo para excluir las hojas q quieras en la linea 3
(ojo solo es un fragmento del codigo):

Saludos,
KL

For Each Hoja In ThisWorkbook.Worksheets
Select Case Hoja.Name
Case "HojaSumar", "Perez", "Sanchez" 'etc.
Case Else
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambiar el rango si lo quiere
If Not IsError(C.Value) Then ' sin error
If C.Value <> "" Then ' sin vacias
If D.Exists(C.Value) Then
D.Item(C.Value) = D.Item(C.Value) + 1
Else
D.Add C.Value, 1
End If
End If
End If
Next C
End Select
Next Hoja
Post by Raúl Z.
Hola Daniel,
Muchas Gracias
Tu codigo me parece bastante interesante, lo estoy probando, al igual que
el
de Daniel, despues vere por cual me decido, ambos funcionan, aunque tengo
que
hacerle algunos retoques.
Alguno de ellos es eliminar de la busqueda determinadas hojas, x ej. la
hoja
"Perez" la hoja "Sanchez" etc. tendria que ir aqui no?
If Hoja.Name <> "HojaSumar" Then
Espero tu amable respuesta
Muchas Gracias.
Raul
Post by Daniel.M
Hola Raul,
Tiene que tener una hoja que se llama "HojarSumar" para inscribir los
resultados.
La macro siguiente monstra las duplicadas (pero no los errores o celdas vacias).
Puede cambiar el rango (evidamente).
Sub BuscarDuplicadasVariasHojas()
Dim Hoja As Worksheet, C As Range
Dim D As Object, Llaves As Variant, Veces As Variant
Dim res As Variant ' resultado de Match()
Worksheets("HojaSumar").Range("A2:B10000").ClearContents
Set D = CreateObject("Scripting.Dictionary")
For Each Hoja In ThisWorkbook.Worksheets
If Hoja.Name <> "HojaSumar" Then
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambiar el rango si lo quiere
If Not IsError(C.Value) Then ' sin error
If C.Value <> "" Then ' sin vacias
If D.Exists(C.Value) Then
D.Item(C.Value) = D.Item(C.Value) + 1
Else
D.Add C.Value, 1
End If
End If
End If
Next C
End If
Next Hoja
Llaves = D.Keys
Veces = D.Items
'Monstrar resultados
With Worksheets("HojaSumar").Range("A2").Resize(D.Count)
.Value = Application.Transpose(Llaves)
.Offset(0, 1).Value = Application.Transpose(Veces)
.Resize(, 2).Sort key1:=.Cells(1, 2), order1:=xlDescending
res = Application.Match(1, .Offset(0, 1), 0)
If Not IsError(res) Then
.Offset(res - 1, 0).Resize(, 2).ClearContents
End If
End With
Set D = Nothing
End Sub
Saludos,
Daniel M.
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
KL
2004-12-27 10:44:12 UTC
Raul,

Es mas - yo te recomiendo q uses el macro de Daniel M., es mas rapido y mas
elegante.

Saludos,
KL
Post by Raúl Z.
Muchas gracias KL, estoy probando lo tuyo y lo de Daniel M., las 2 funcionan,
pero la de Daniel M. es menos compleja y mas simple me parece.
Gracias x tu interes.
Raul
Post by "KL" <lapink2000(at)hotmail.com>
'---------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
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
' 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 "KL" <lapink2000(at)hotmail.com>
Raul,
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 KL
Raul,
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 "KL" <lapink2000(at)hotmail.com>
Raul,
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
Página siguiente >
Página 1 de 3