Modificar Macro para que ejecute solo en una fila
Sub ExtraerDuplicados()
Dim dic As Object
Dim i As Long, j As Long, k As Long
Dim a As Variant, b As Variant
'
Set dic = CreateObject("Scripting.Dictionary")
a = Range("A10:BXY" & Range("A" & Rows.Count).End(3).Row).Value 'RANGO A BUSCAR DUPLICADOS
ReDim b(1 To UBound(a, 1), 1 To 1000)
'
For i = 1 To UBound(a, 1)
For j = 1 To 1000
If a(i, j) <> "" Then dic(a(i, j)) = Empty
Next
k = 0
For j = 1002 To 2001
If dic.exists(a(i, j)) Then
k = k + 1
b(i, k) = a(i, j)
End If
Next
dic.RemoveAll
Next
'
Range("BYA10").Resize(UBound(b, 1), UBound(b, 2)).Value = b 'CELDA DONDE EMPIEZA A PEGAR
End SubHola buena tarde. Por favor solicito nuevamente ayuda para modificar esta macro. actualmente trabaja de la siguiente manera.. Como ven en la imagen anterior. La macro compara los numeros de los dos primeros rangos, columnas "A y BXY" y pega los números repetidos a partir de la columna BYA.
Ella ejecuta actualmente sobre los datos de todooo el rango. Osea al ejecutarla una sola vez, analiza todos los datos de los rangos desde la fila 10 hasta la fila que tenga datos,, ejemplo fila 2000 o mas.
La macro funciona bien para lo que la necesitaba en su momento y me la proporciono un experto de esta maravillosa plataforma.
Ahora quiero modificar para que de el resultado SOLAMENTE en la fila que este activa. Amanera de ejemplo coloco la siguiente imagen:
Osea, a manera de ejemplo, en la imagen, la fila activa en ese momento es la fila "14", entonces solo ejecute el resultado en dicha fila, y las otras las deje tal cual como esta.. Y que si la fila activa esta en alguna columna, se quede en esa fila, sin mover donde este activa en ese momento, osea, si casilla activa es la "ROM14" ejecute en esa fila pero el cursor siga activo sin moverse de dicha fila..
No se si sea difícil modificar o fácil porque no tengo conocimientos sobre macros
Agradezco muchísimo de su ayuda y quedo atento a cualquier requerimiento
1 Respuesta
Te paso la macro:
Sub ExtraerDuplicados()
'Por Dante Amor
Dim dic As Object
Dim i As Long, j As Long, k As Long
Dim a As Variant, b As Variant
Dim fila As Long
'
Set dic = CreateObject("Scripting.Dictionary")
fila = ActiveCell.Row
a = Range("A" & fila & ":BXY" & fila).Value 'RANGO A BUSCAR DUPLICADOS
ReDim b(1 To 1, 1 To 1000)
'
i = 1
For j = 1 To 1000
If a(i, j) <> "" Then dic(a(i, j)) = Empty
Next
k = 0
For j = 1002 To 2001
If dic.exists(a(i, j)) Then
k = k + 1
b(i, k) = a(i, j)
End If
Next
'
Range("BYA" & fila).Resize(1, UBound(b, 2)).Value = b 'CELDA DONDE EMPIEZA A PEGAR
End Sub[No olvides valorar.
