Macro para Ordenar

Respuesta de
a
Usuario

Buen Dia Expertos,

 

Tengo una Macro que me sirve para ordenar dos columnas A y B y las reordena a partir de la D:

en la primera están los CLIENTES y en la segunda están los DEPARTAMENTOS a los que le corresponde, coloca solo una vez al cliente y en las siguientes columnas los departamentos a los que le corresponde, y si hay repetidos solo cuenta uno.

 

El único problema en esta macro es que demora mucho porque la utilizo para bases grandes. agradecería que me apoyen para poder resolver este problema de lentitud.

 

 

Sub prueba()
Range("a1").Select
Dim i As Integer
Do
i = ActiveCell.Row
buscando = ActiveCell.Value
fila = ActiveCell.Row
If Range("d:d").Find(buscando) Is Nothing Then
Range("D" & fila).Value = buscando
Range("D" & fila).Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value
Else
fila2 = Range("d:d").Find(buscando).Row
If Range(Range("d" & fila2), Range("d" & fila2).End(xlToRight)).Find(ActiveCell.Offset(0, 1).Value) Is Nothing Then
Range("d:d").Find(buscando).End(xlToRight).Offset(0, 1).Value = ActiveCell.Offset(0, 1).Value
End If
End If
i = i + 1
Range("a" & i).Select
Loop While ActiveCell.Value <> ""
End Sub

Avatar
Experto

Hola:

Para cambiar la macro, me puedes enviar una muestra de tu archivo, en una hoja me pones los datos desordenados, y en otra hoja me pones los datos como los deja la macro.

Mi correo jov19p3@yahoo.com
En el asunto del correo escribe tu nombre de usuario y el título de esta pregunta.
Avísame en esta pregunta cuando me lo hayas enviado.
 
Saludos.DAM

Usuario

enviado

Usuario

Hola Dam, 

 

He probado la macro pero la diferencia no es mucha, hay algo que aun se pueda hacer?

Avatar
Experto

Que tal, prueba con la siguiente macro, por lo menos, ya lo hace en la mitad de tiempo. Te va a dejar la información en la columna G y ya ordenada.

 

Sub ordenar()
'Por.DAM
Application.ScreenUpdating = False
    uf = Range("A" & Rows.Count).End(xlUp).Row
    uc = ActiveCell.SpecialCells(xlLastCell).Column
    Range(Cells(2, "D"), Cells(uf, uc)).ClearContents
    Range("A1:B" & uf).Copy Range("D1")
    ActiveSheet.Range("$D$1:$E$" & uf).RemoveDuplicates _
        Columns:=Array(1, 2), Header:=xlYes
    c = "D"
    ant = Range(c & 2)
    uf = Range(c & Rows.Count).End(xlUp).Row
    k = 2
    m = 2
    For i = 2 To uf + 1
        If ant <> Cells(i, c) Then
            Cells(m, "G") = ant
            Range(Cells(k, "E"), Cells(i - 1, "E")).Copy
            ActiveSheet.Cells(m, "H").PasteSpecial Transpose:=True
            k = i
            m = m + 1
        End If
        ant = Cells(i, c)
    Next
Application.ScreenUpdating = True
MsgBox "Proceso Terminado", vbInformation
End Sub
 

 También si pudieras probar en otra computadora, comas procesador y más memoria.

 

Saludos.DAM
Si es lo que necesitas, por favor, podrías finalizar la pregunta. Gracias

Usuario

muchas gracias esta mejor