Números repetidos

Daniel,

A ver la otra version sin Dictionary, me interesa.

Saludos,
KL

"Daniel.M" wrote in message
news:

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

KL,

Aqui tiene :-)

Saludos,

Daniel M.

Sub BuscarDuplicadasEnVariasHojas()
Dim Hoja As Worksheet, C As Range, Resultados As Range
Dim res As Variant ' resultado de Match()
Dim j As Long
Dim LLaves As Variant, Veces As Variant, Direcciones As Variant

Set Resultados = Worksheets("HojaSumar").Range("A2:C10000")

j = 0
For Each Hoja In ActiveWorkbook.Worksheets
Select Case Hoja.Name
Case "HojaSumar", "Perez", "Sanchez" 'etc.
Case Else
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambia el rango si lo quieres
If Not IsError(C.Value) Then ' sin celda con error
If C.Value <> "" Then ' sin celda vacia
If j = 0 Then
res = CVErr(xlErrNA)
ReDim LLaves(1 To 1)
ReDim Veces(1 To 1)
ReDim Direcciones(1 To 1)
Else
res = Application.Match(C.Value, LLaves, 0)
End If
If IsError(res) Then
j = j + 1
ReDim Preserve LLaves(1 To j)
ReDim Preserve Veces(1 To j)
ReDim Preserve Direcciones(1 To j)
LLaves(j) = C.Value
Veces(j) = 1
Direcciones(j) = LaDireccion(C)
Else
Veces(res) = Veces(res) + 1
Direcciones(res) = Direcciones(res) & " " & _
LaDireccion(C)
End If
End If
End If
Next C
End Select
Next Hoja

'Monstrar resultados
Resultados.ClearContents ' borrar resultados viejos
'

With Resultados.Resize(j, 1)
.Value = Application.Transpose(LLaves) ' columna 1 ==> llaves
.Offset(0, 1).Value = Application.Transpose(Veces) ' column 2 ==> veces
' column 3 ==> direcciones
.Offset(0, 2).Value = Application.Transpose(Direcciones)
.Resize(, 3).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
' cancelar todas filas donde hay 1 vez la llave
.Offset(res - 1, 0).Resize(, 3).ClearContents
End If
End With

End Sub


Private Function LaDireccion(C As Range) As String
Dim s As String, i As Integer
s = C.Address(False, False, xlA1, True)
i = InStr(1, s, "]")
LaDireccion = Mid(s, i + 1)
End Function

Gracias,

KL

"Daniel.M" wrote in message
news:

KL,

Aqui tiene :-)

Saludos,

Daniel M.

Sub BuscarDuplicadasEnVariasHojas()
Dim Hoja As Worksheet, C As Range, Resultados As Range
Dim res As Variant ' resultado de Match()
Dim j As Long
Dim LLaves As Variant, Veces As Variant, Direcciones As Variant

Set Resultados = Worksheets("HojaSumar").Range("A2:C10000")

j = 0
For Each Hoja In ActiveWorkbook.Worksheets
Select Case Hoja.Name
Case "HojaSumar", "Perez", "Sanchez" 'etc.
Case Else
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambia el rango si lo quieres
If Not IsError(C.Value) Then ' sin celda con error
If C.Value <> "" Then ' sin celda vacia
If j = 0 Then
res = CVErr(xlErrNA)
ReDim LLaves(1 To 1)
ReDim Veces(1 To 1)
ReDim Direcciones(1 To 1)
Else
res = Application.Match(C.Value, LLaves, 0)
End If
If IsError(res) Then
j = j + 1
ReDim Preserve LLaves(1 To j)
ReDim Preserve Veces(1 To j)
ReDim Preserve Direcciones(1 To j)
LLaves(j) = C.Value
Veces(j) = 1
Direcciones(j) = LaDireccion(C)
Else
Veces(res) = Veces(res) + 1
Direcciones(res) = Direcciones(res) & " " & _
LaDireccion(C)
End If
End If
End If
Next C
End Select
Next Hoja

'Monstrar resultados
Resultados.ClearContents ' borrar resultados viejos
'

With Resultados.Resize(j, 1)
.Value = Application.Transpose(LLaves) ' columna 1 ==> llaves
.Offset(0, 1).Value = Application.Transpose(Veces) ' column 2 ==> veces
' column 3 ==> direcciones
.Offset(0, 2).Value = Application.Transpose(Direcciones)
.Resize(, 3).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
' cancelar todas filas donde hay 1 vez la llave
.Offset(res - 1, 0).Resize(, 3).ClearContents
End If
End With

End Sub


Private Function LaDireccion(C As Range) As String
Dim s As String, i As Integer
s = C.Address(False, False, xlA1, True)
i = InStr(1, s, "]")
LaDireccion = Mid(s, i + 1)
End Function

Hola Daniel
Muchas gracias.
Me dá un error en:
.Offset(0, 2).Value = Application.Transpose(Direcciones)
Estoy usando la versión sin Dictionary.

Raúl

"Daniel.M" escribió:

KL,

Aqui tiene :-)

Saludos,

Daniel M.

Sub BuscarDuplicadasEnVariasHojas()
Dim Hoja As Worksheet, C As Range, Resultados As Range
Dim res As Variant ' resultado de Match()
Dim j As Long
Dim LLaves As Variant, Veces As Variant, Direcciones As Variant

Set Resultados = Worksheets("HojaSumar").Range("A2:C10000")

j = 0
For Each Hoja In ActiveWorkbook.Worksheets
Select Case Hoja.Name
Case "HojaSumar", "Perez", "Sanchez" 'etc.
Case Else
For Each C In Intersect(Hoja.Range("A:D"), Hoja.UsedRange)
' cambia el rango si lo quieres
If Not IsError(C.Value) Then ' sin celda con error
If C.Value <> "" Then ' sin celda vacia
If j = 0 Then
res = CVErr(xlErrNA)
ReDim LLaves(1 To 1)
ReDim Veces(1 To 1)
ReDim Direcciones(1 To 1)
Else
res = Application.Match(C.Value, LLaves, 0)
End If
If IsError(res) Then
j = j + 1
ReDim Preserve LLaves(1 To j)
ReDim Preserve Veces(1 To j)
ReDim Preserve Direcciones(1 To j)
LLaves(j) = C.Value
Veces(j) = 1
Direcciones(j) = LaDireccion(C)
Else
Veces(res) = Veces(res) + 1
Direcciones(res) = Direcciones(res) & " " & _
LaDireccion(C)
End If
End If
End If
Next C
End Select
Next Hoja

'Monstrar resultados
Resultados.ClearContents ' borrar resultados viejos
'

With Resultados.Resize(j, 1)
.Value = Application.Transpose(LLaves) ' columna 1 ==> llaves
.Offset(0, 1).Value = Application.Transpose(Veces) ' column 2 ==> veces
' column 3 ==> direcciones
.Offset(0, 2).Value = Application.Transpose(Direcciones)
.Resize(, 3).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
' cancelar todas filas donde hay 1 vez la llave
.Offset(res - 1, 0).Resize(, 3).ClearContents
End If
End With

End Sub


Private Function LaDireccion(C As Range) As String
Dim s As String, i As Integer
s = C.Address(False, False, xlA1, True)
i = InStr(1, s, "]")
LaDireccion = Mid(s, i + 1)
End Function

Por fin anduvo esto Daniel
Muchiiiiiiiiiiiiiiiiisimas gracias al igual que al amigo KL que siempre se
interesó
Solo tuve que hacerle una correción y es agregar:
Worksheets("HojaSumar").Range("A2:B10000").ClearContents
Porque sino me sumaba la cantidad de repetidos como números repetidos, se
entiende?
Muchas gracias y adios.

Raúl Z.


"Daniel.M" escribió:

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