Ayuda con un codigo

04/03/2005 - 23:31 por Iggv | Informe spam
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
 

Leer las respuestas

#1 KL
05/03/2005 - 00:34 | Informe spam
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


Preguntas similares