Ayuda con un codigo

Hola Iggv,

Mira a ver si te sirve el siguiente codigo q DanielM y yo hemos creado para
un caso parecido. Este codigo asume (entre otras cosas) q hay una hoja
llamada "Resumen" en la q se depositaran los resultados, q la base de datos
se encuentra en la hoja llamada "Hoja1" y q los valores repetidos se
encuentran en la columna [A] de la base de datos. Lo he modificado bastante,
pero no he tenido la ocasion para probarlo, asi que si da errores comentas.

Saludos,
KL

'Inicio Codigo-
Sub BuscarDuplicadasEnVariasHojas()
Dim C As Range
Dim Resultados As Range
Dim res As Variant 'resultado de Match()
Dim j As Long
Dim i As Long
Dim k As Long
Dim LLaves As Variant
Dim Veces As Variant
Dim Direcciones As Variant
Dim miRng As Range 'variable para el rango a evaluar.

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

'Establece el rango a evaluar para la hoja.
With Worksheets("Hoja1")
Set miRng = .Range(.Cells(2, 1), _
.Cells(.Range("A65536").End(xlUp).Row, 1))
End With

For Each C In miRng
'saltar celdas con error
If Not IsError(C.Value) Then
'saltar celdas vacias
If C.Value <> "" Then
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

'Borrar resultados anteriores
Resultados.ClearContents

'Mostrar resultados
k = 1
For i = 1 To j
If Veces(i) > 1 Then
Resultados(k, 1) = LLaves(i)
Resultados(k, 2) = Veces(i)
Resultados(k, 3) = Direcciones(i)
k = k + 1
End If
Next i

Resultados.Resize(k, 3).Sort key1:=Resultados.Cells(1, 2), _
order1:=xlDescending, header:=xlNo
End Sub

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



"Iggv" wrote in message
news:%

Hola a todos en este foro
En un libro de Excel encontre la macro que adjunto mas abajop.
Esta macro permite encontrar valores duplicados dentro de un rango
seleccionado, y a los valores repetidos los marca en rojo. Lo que me
gustaria es que luego de efectuarse la busqueda se generara un pequeño
resumen donde se mostrara las celdas que contienen valores repetidos y la
ubicacion de las celdas originales.
Espero haber sido claro y que me puedan ayudar.
Desde ya muchisimas gracias y quedo a la espera de alguna respuesta

Sub Duplicados()
'
' Duplicados Macro
' Macro grabada el 04/03/2005 por ana
'
' Acceso directo: CTRL+d
'
Application.ScreenUpdating = False
Rng = Selection.Rows.Count
For i = Rng To 1 Step -1
myCheck = ActiveCell
ActiveCell.Offset(1, 0).Select
For j = 1 To i
If ActiveCell = myCheck Then
Selection.Font.Bold = True
Selection.Font.ColorIndex = 3
End If
ActiveCell.Offset(1, 0).Select
Next j
ActiveCell.Offset(-i, 0).Select
Next i
Application.ScreenUpdating = True
End Sub

ok lo pruebo y te comento

"KL" escribió en el mensaje
news:

Hola Iggv,

Mira a ver si te sirve el siguiente codigo q DanielM y yo hemos creado

para

un caso parecido. Este codigo asume (entre otras cosas) q hay una hoja
llamada "Resumen" en la q se depositaran los resultados, q la base de

datos

se encuentra en la hoja llamada "Hoja1" y q los valores repetidos se
encuentran en la columna [A] de la base de datos. Lo he modificado

bastante,

pero no he tenido la ocasion para probarlo, asi que si da errores

comentas.

Saludos,
KL

'Inicio Codigo-
Sub BuscarDuplicadasEnVariasHojas()
Dim C As Range
Dim Resultados As Range
Dim res As Variant 'resultado de Match()
Dim j As Long
Dim i As Long
Dim k As Long
Dim LLaves As Variant
Dim Veces As Variant
Dim Direcciones As Variant
Dim miRng As Range 'variable para el rango a evaluar.

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

'Establece el rango a evaluar para la hoja.
With Worksheets("Hoja1")
Set miRng = .Range(.Cells(2, 1), _
.Cells(.Range("A65536").End(xlUp).Row, 1))
End With

For Each C In miRng
'saltar celdas con error
If Not IsError(C.Value) Then
'saltar celdas vacias
If C.Value <> "" Then
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

'Borrar resultados anteriores
Resultados.ClearContents

'Mostrar resultados
k = 1
For i = 1 To j
If Veces(i) > 1 Then
Resultados(k, 1) = LLaves(i)
Resultados(k, 2) = Veces(i)
Resultados(k, 3) = Direcciones(i)
k = k + 1
End If
Next i

Resultados.Resize(k, 3).Sort key1:=Resultados.Cells(1, 2), _
order1:=xlDescending, header:=xlNo
End Sub

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



"Iggv" wrote in message
news:%
> Hola a todos en este foro
> En un libro de Excel encontre la macro que adjunto mas abajop.
> Esta macro permite encontrar valores duplicados dentro de un rango
> seleccionado, y a los valores repetidos los marca en rojo. Lo que me
> gustaria es que luego de efectuarse la busqueda se generara un pequeño
> resumen donde se mostrara las celdas que contienen valores repetidos y

la

> ubicacion de las celdas originales.
> Espero haber sido claro y que me puedan ayudar.
> Desde ya muchisimas gracias y quedo a la espera de alguna respuesta
>
> Sub Duplicados()
> '
> ' Duplicados Macro
> ' Macro grabada el 04/03/2005 por ana
> '
> ' Acceso directo: CTRL+d
> '
> Application.ScreenUpdating = False
> Rng = Selection.Rows.Count
> For i = Rng To 1 Step -1
> myCheck = ActiveCell
> ActiveCell.Offset(1, 0).Select
> For j = 1 To i
> If ActiveCell = myCheck Then
> Selection.Font.Bold = True
> Selection.Font.ColorIndex = 3
> End If
> ActiveCell.Offset(1, 0).Select
> Next j
> ActiveCell.Offset(-i, 0).Select
> Next i
> Application.ScreenUpdating = True
> End Sub
>
>

Funciona perfecto.
Muchisimas gracias


"Iggv" escribió en el mensaje
news:

ok lo pruebo y te comento

"KL" escribió en el mensaje
news:
> Hola Iggv,
>
> Mira a ver si te sirve el siguiente codigo q DanielM y yo hemos creado
para
> un caso parecido. Este codigo asume (entre otras cosas) q hay una hoja
> llamada "Resumen" en la q se depositaran los resultados, q la base de
datos
> se encuentra en la hoja llamada "Hoja1" y q los valores repetidos se
> encuentran en la columna [A] de la base de datos. Lo he modificado
bastante,
> pero no he tenido la ocasion para probarlo, asi que si da errores
comentas.
>
> Saludos,
> KL
>
> 'Inicio Codigo-
> Sub BuscarDuplicadasEnVariasHojas()
> Dim C As Range
> Dim Resultados As Range
> Dim res As Variant 'resultado de Match()
> Dim j As Long
> Dim i As Long
> Dim k As Long
> Dim LLaves As Variant
> Dim Veces As Variant
> Dim Direcciones As Variant
> Dim miRng As Range 'variable para el rango a evaluar.
>
> Set Resultados = Worksheets("Resumen").Range("A2:C10000")
>
> 'Establece el rango a evaluar para la hoja.
> With Worksheets("Hoja1")
> Set miRng = .Range(.Cells(2, 1), _
> .Cells(.Range("A65536").End(xlUp).Row, 1))
> End With
>
> For Each C In miRng
> 'saltar celdas con error
> If Not IsError(C.Value) Then
> 'saltar celdas vacias
> If C.Value <> "" Then
> 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
>
> 'Borrar resultados anteriores
> Resultados.ClearContents
>
> 'Mostrar resultados
> k = 1
> For i = 1 To j
> If Veces(i) > 1 Then
> Resultados(k, 1) = LLaves(i)
> Resultados(k, 2) = Veces(i)
> Resultados(k, 3) = Direcciones(i)
> k = k + 1
> End If
> Next i
>
> Resultados.Resize(k, 3).Sort key1:=Resultados.Cells(1, 2), _
> order1:=xlDescending, header:=xlNo
> End Sub
>
> Private Function LaDireccion(C As Range) As String
> Dim s As String
> Dim i As Integer
> s = C.Address(False, False, xlA1, True)
> i = InStr(1, s, "]")
> LaDireccion = Mid(s, i + 1)
> End Function
> 'Fin Codigo
>
>
>
> "Iggv" wrote in message
> news:%
> > Hola a todos en este foro
> > En un libro de Excel encontre la macro que adjunto mas abajop.
> > Esta macro permite encontrar valores duplicados dentro de un rango
> > seleccionado, y a los valores repetidos los marca en rojo. Lo que me
> > gustaria es que luego de efectuarse la busqueda se generara un pequeño
> > resumen donde se mostrara las celdas que contienen valores repetidos y
la
> > ubicacion de las celdas originales.
> > Espero haber sido claro y que me puedan ayudar.
> > Desde ya muchisimas gracias y quedo a la espera de alguna respuesta
> >
> > Sub Duplicados()
> > '
> > ' Duplicados Macro
> > ' Macro grabada el 04/03/2005 por ana
> > '
> > ' Acceso directo: CTRL+d
> > '
> > Application.ScreenUpdating = False
> > Rng = Selection.Rows.Count
> > For i = Rng To 1 Step -1
> > myCheck = ActiveCell
> > ActiveCell.Offset(1, 0).Select
> > For j = 1 To i
> > If ActiveCell = myCheck Then
> > Selection.Font.Bold = True
> > Selection.Font.ColorIndex = 3
> > End If
> > ActiveCell.Offset(1, 0).Select
> > Next j
> > ActiveCell.Offset(-i, 0).Select
> > Next i
> > Application.ScreenUpdating = True
> > End Sub
> >
> >
>
>