Números repetidos

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

"KL" escribió:

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


"KL" <lapink2000(at)hotmail.com> wrote in message
news:Ok$
> 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
>
> "KL" wrote in message
> news:192yd.4532053$
>> Raul,
>>
>> Tienes razon - no funciona. Voy a ver si se me ocurre otra cosa.
>>
>> KL
>>
>> "Raul Z." wrote in message
>> news:
>>> 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
>>>
>>> "KL" escribio:
>>>
>>>> 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
>>>>
>>>>
>>>>
>>>>
>>>> "Raul Z." wrote in message
>>>> news:
>>>> > 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
>>>> > sea que siguiendo el ej. anterior me diga:
>>>> >
>>>> > A
>>>> > 1 28
>>>> > 2 32
>>>> > 3 11
>>>> >
>>>> > etc.etc.
>>>> > Muchas gracias
>>>> > Raul
>>>>
>>>>
>>>>
>>
>>
>
>

Muchas Gracias Luis.

Raúl

"Luis Garcia" escribió:

"KL" <lapink2000(at)hotmail.com> escribió en...
> 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

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


"Raul Z." wrote in message
news:

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

"Daniel.M" escribio:

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.

"Raul Z." wrote in message
news:
> 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
> sea que siguiendo el ej. anterior me diga:
>
> A
> 1 28
> 2 32
> 3 11
>
> etc.etc.
> Muchas gracias
> Raul

Raul,

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

Saludos,
KL

"Raul Z." wrote in message
news:

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

"KL" escribio:

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


"KL" <lapink2000(at)hotmail.com> wrote in message
news:Ok$
> 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
>
> "KL" wrote in message
> news:192yd.4532053$
>> Raul,
>>
>> Tienes razon - no funciona. Voy a ver si se me ocurre otra cosa.
>>
>> KL
>>
>> "Raul Z." wrote in message
>> news:
>>> 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
>>>
>>> "KL" escribio:
>>>
>>>> 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
>>>>
>>>>
>>>>
>>>>
>>>> "Raul Z." wrote in message
>>>> news:
>>>> > 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
>>>> > sea que siguiendo el ej. anterior me diga:
>>>> >
>>>> > A
>>>> > 1 28
>>>> > 2 32
>>>> > 3 11
>>>> >
>>>> > etc.etc.
>>>> > Muchas gracias
>>>> > Raul
>>>>
>>>>
>>>>
>>
>>
>
>

Buen Dia,

Exactamente como KL te lo dijo.

Y tambien, me parece interesante de cambiar ThisWorkbook por ActiveWorkbook

Entonces, aqui tiene una otra version (yo tengo una otra version que funciona
sin el objecto Dictionary si lo quieres):

Sub BuscarDuplicadasVariasHojas()

Dim Hoja As Worksheet, Celda As Range, Resultados As Range
Dim D As Object, LLaves As Variant, Veces As Variant
Dim res As Variant ' resultado de Match()

Set Resultados = Worksheets("HojaSumar").Range("A2:B10000") ' cambiar

Set D = CreateObject("Scripting.Dictionary")

For Each Hoja In ActiveWorkbook.Worksheets
Select Case Hoja.Name
Case "HojaSumar", "Perez", "Sanchez" 'etc.
Case Else
For Each Celda In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambie el rango si lo quieres
If Not IsError(Celda.Value) Then ' sin celda con error
If Celda.Value <> "" Then ' sin celda vacia
If D.Exists(Celda.Value) Then ' si el valor exista in el
dictionario
D.Item(Celda.Value) = D.Item(Celda.Value) + 1 ' lo
conta una vez mas
Else
D.Add Celda.Value, 1 ' initialmente
End If
End If ' verif sin celda vacia
End If ' verif sin error
Next Celda
End Select ' verif el nombre de la hoja
Next Hoja

'Monstrar resultados
LLaves = D.Keys
Veces = D.Items
Resultados.ClearContents ' borrar resultados viejos

With Resultados.Resize(D.Count, 1)
.Value = Application.Transpose(LLaves) ' columna 1 ==> llaves
.Offset(0, 1).Value = Application.Transpose(Veces) ' column 2 ==> veces
.Resize(, 2).Sort key1:=.Cells(1, 2), order1:=xlDescending, header:=xlNo
res = Application.Match(1, .Offset(0, 1), 0) ' busca primero 1 en veces
If Not IsError(res) Then ' si encontrado 1
' borrar todas filas de los resultados en la cuales
' vemos 1 llave presentada una vez
.Offset(res - 1, 0).Resize(, 2).ClearContents
End If
End With

Set D = Nothing ' cleanup

End Sub