Visual Basic para Aplicaciones - Macro para copiar celdas de forma rapida

Life is soft - evento anual de software empresarial
   
Vista:

Macro para copiar celdas de forma rapida

Publicado por javier newmelvin@hotmail.com (11 intervenciones) el 11/08/2016 18:13:12
Buenas Noches
por este medio les envio Saludos

y les pido si alguien pudiera apoyarme en revisar mi macro
esta compara dos columnas y cuando encuentra datos iguales copia algunas celdas de la hoja 1 a la hoja 2
en realidad fuinciona bien

pero como tengo mas de 300 mil registros a comparar tarda mucho (mas de 5 horas ) en realizar el proceso...

tal vez si pudiera alguien revisarla y ver si se puede hacer "algo"para que sea mas rapido el proceso..

envio el codigo
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Actualizar_datos()
 
Dim x As Long, Fila As Range
 
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
 
 
For x = 2 To Hoja2.Range("A1").End(xlDown).Row
   Set Fila = Hoja1.Columns("T").Find(what:=Hoja2.Range("A" & x), lookat:=xlWhole)
   If Not Fila Is Nothing Then
      Hoja2.Range("J" & x) = Hoja1.Range("U" & Fila.Row)
   End If
Next
 
With Application
    .ScreenUpdating = True
    .Calculation = xlAutomatic
    .EnableEvents = True
End With
MsgBox "Proceso completado"
 
End Sub
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
información
Otras secciones de LWP con contenido de Visual Basic para Aplicaciones
- Código fuente de Visual Basic para Aplicaciones
- Cursos de Visual Basic para Aplicaciones
- Temas de Visual Basic para Aplicaciones
información
Códigos de Visual Basic para Aplicaciones
- Juego del Ahorcado
- Rompecabezas
- Cajero Automatico

Macro para copiar celdas de forma rapida

Publicado por JuanC juanc2942@gmail.com (431 intervenciones) el 12/08/2016 02:49:42
pasame el archivo x mail y pruebo...
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana

Macro para copiar celdas de forma rapida

Publicado por Antoni Masana (47 intervenciones) el 12/08/2016 12:47:27
El problema de que tarde tanto este proceso esta en la línea 2, el Find y ¿por que? pues por la sencilla razón de que busca secuencialmente.

Para que te hagas una ligera idea de lo que pasa si las 100 primeras celdas de la columna A no existen en la columna T realiza 30.000.000 comparaciones. Y suponiendo que no coincida ninguno raliza 90.000.000.000 comparaciones.

Hay una forma de hacerlo con menos 5.700.000 he incluso con menos unas 300.000

1
2
3
4
5
6
For x = 2 To Hoja2.Range("A1").End(xlDown).Row
   Set Fila = Hoja1.Columns("T").Find(what:=Hoja2.Range("A" & x), lookat:=xlWhole)
   If Not Fila Is Nothing Then
      Hoja2.Range("J" & x) = Hoja1.Range("U" & Fila.Row)
   End If
Next

Para el primer supuesto necesitas ordenar la columna T y realizas una búsqueda manual con el sistema dicotómico.

Para el segundo supuesto necesitas un poco mas de codigo.
- Creas una hoja nueva.
- Copias la columna A de la hoja1 a la columna A de la hoja nueva.
- Copias la columna U de la hoja1 a la columna B de la hoja nueva.
- Copias la columna T de la hoja1 a la columna C de la hoja nueva.
- Seleccionas la columna la hoja nueva.
- Seleccionas las columnas A y B y ordenas por la columna A.
- Ordenas la columna C.

Y ahora viene lo bueno.

Recorres la columna A y C a la vez. Si A es mayor que C lees al siguiente celda de C y vuelves a comparar, si A es menor que C lees la siguiente celda de A y vuelves a comparar y si A es igual a C copias la columna B en la hoja 2 y lees el siguiente de A y si no tienes repeticiones en la columna A el siguiente de la columna C.

En còdigo en forma esquemático.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Lin_A=2
Lin_C=2
Fin = 0
 
While Fin = 0
   if Celda("A" & Lin_A) = Celda("C" & Lin_C) then
      Copia Celda_B a Hoja_2
      Lin_A++
   else
      if Celda("A" & Lin_A) > Celda("C" & Lin_C) then
         Lin_C++
      else
         Lin_A++
      end if
   end if
   If Lin_A > Hoja_New.Range("A1").End(xlDown).Row then Fin=1
   If Lin_C > Hoja_New.Range("C1").End(xlDown).Row then Fin=1
wend

Y cuando finaliza eliminas la hoja nueva. No es tan complicado como parece, pero muchisimo más rapido.

Y copiar es muy rápido si no lo envias al portapapeles. Esto tiene truco.

Saludos.

NOTA: Si juanC no te puede dar una solución más optima pasamelo y te lo pruebo.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Macro para copiar celdas de forma rapida

Publicado por javier (11 intervenciones) el 12/08/2016 16:55:06
Hola Buen dia de antemano gracias por tomar tiempo para veer mi solicitud

envio el archivo para q lo puedan revisar ..
se deben considerar al menos dos cosas importantes.
a... la columnas con titulo amarillo son las que copian de una hoja a otra cuando encuentren coincidentes ..
b..... no se deben de ordenar los datos..
c. solo puse una parte de mis datos ya q como les comento son mas de 300000





espero se pueda hacer algo ... saludos ..
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Macro para copiar celdas de forma rapida

Publicado por Antoni Masana amasana@hotmail.com (47 intervenciones) el 12/08/2016 23:13:00
Buenas Javier,

¿puedes enviármelo a mi correo sin comprimir?

Ahora no tengo un des compresor y tendría que esperar al Martes para mirarlo.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Macro para copiar celdas de forma rapida

Publicado por JuanC juanc2942@gmail.com (431 intervenciones) el 13/08/2016 01:06:58
De momento es todo lo que pude...según mis cálculos es mucho más rápido...

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub Actualizar_datos2()
Dim r As Range
Dim mx As Variant, i&, m&, j&
Dim mx2 As Variant, m2&
 
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
 
Set r = Hoja2.Range("A1:A" & Hoja2.Range("A1").End(xlDown).Row)
With r
     m = .Rows.Count
     mx = .Value
End With
 
Set r = Hoja1.Range("T1:T" & Hoja1.Range("T1").End(xlDown).Row)
With r
     m2 = .Rows.Count
     mx2 = .Value
End With
 
For i = 1 To m
    For j = 1 To m2
        If mx(i, 1) = mx2(j, 1) Then
           Hoja2.Cells(i, 10) = Hoja1.Cells(j, 21)
           Exit For
        End If
    Next
Next
 
With Application
    .ScreenUpdating = True
    .Calculation = xlAutomatic
    .EnableEvents = True
End With
End Sub
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana

Macro para copiar celdas de forma rapida

Publicado por Antoni Masana (47 intervenciones) el 16/08/2016 11:11:06
Te pongo la Macro para actualizar la hoja más rápido.

Creo que debería ser mucho más rápido.

Prueba la Macro de JuanC y la mía y escoge la que quieras, que sea más rápida y más fácil de mantener, la mia es más compleja, no se si más rápida pero piensa que en el futuro si tienes que hacer cambios debes entender que hace.

Y si no como siempre pasa en informático tienes dos o más formas de hacer lo mismo.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
Sub Actualizar_Rapido()
'
' Macro2 Macro
'
    Dim Total_Lineas_A As Long, Fila_A As Long, Codigo_A As String, New_Hoja As String, _
        Total_Lineas_T As Long, Fila_T As Long, Codigo_T As String, Fin As Byte
 
    Dim Inicio As Long
 
    Inicio = Timer
 
    ' EXPLICACION PASO a PASO
 
    Application.ScreenUpdating = False  ' Evita que refresque mientras se
                                        '   ejecuta la MACRO.
 
    Application.DisplayAlerts = False   ' Evita los mensajes de aviso, en este
                                        '   caso cuando Borra la Nueva Hoja.
 
    ' -1- Busco el número de filas en las columnas Hoja2.A y Hoja1.T
 
    Total_Lineas_A = Sheets("Hoja2").Range("A1").End(xlDown).Row
    Total_Lineas_T = Sheets("Hoja1").Range("T1").End(xlDown).Row
 
    ' -2- Añado una hoja y guardo el nombre que el sistema le dio
 
    Sheets.Add After:=Sheets(Sheets.Count)
    New_Hoja = ActiveSheet.Name
 
    ' =====   Hoja nueva ACTIVA   =====
 
    ' -3- Copia la columna A de la hoja2 a la columna A de la nueva hoja
    '     Copia la columna J de la hoja2 a la columna B de la nueva hoja
 
    Sheets("Hoja2").Range("A:A").Copy Sheets(New_Hoja).Range("A1")
    Sheets("Hoja2").Range("J:J").Copy Sheets(New_Hoja).Range("B1")
 
    ' -4- Ordena las columnas A y B por el valor de la A
 
    Columns("A:B").Select
    Application.CutCopyMode = False
 
    ActiveWorkbook.Worksheets(New_Hoja).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(New_Hoja).Sort.SortFields.Add _
                   Key:=Range("A2:A" & Total_Lineas_A), _
                   SortOn:=xlSortOnValues, _
                   Order:=xlAscending, _
                   DataOption:=xlSortNormal
 
    With ActiveWorkbook.Worksheets(New_Hoja).Sort
        .SetRange Range("A1:B" & Total_Lineas_A)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("A:B").EntireColumn.AutoFit
 
    ' -5- Copia la columna T de la hoja1 a la columna T de la nueva hoja
 
    Sheets("Hoja1").Range("T:T").Copy Sheets(New_Hoja).Range("T1")
 
    ' -6- En la columna U pongo un numerador para saber la línea de origen
 
    Sheets(New_Hoja).Select
    Range("U1") = 1
    Range("U2") = 2
    Range("U3") = 3
 
    Range("U1:U3").Select
    Range("U3").Activate
    Selection.AutoFill Destination:=Range("U1:U" & Total_Lineas_T)
    Range("U1:U" & Total_Lineas_T).Select
 
    ' -7- Ordena las columnas T y U por el valor de la T
 
    Columns("T:U").Select
 
    ActiveWorkbook.Worksheets(New_Hoja).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(New_Hoja).Sort.SortFields.Add _
                   Key:=Range("T2:T" & Total_Lineas_T), _
                   SortOn:=xlSortOnValues, _
                   Order:=xlAscending, _
                   DataOption:=xlSortNormal
 
    With ActiveWorkbook.Worksheets(New_Hoja).Sort
        .SetRange Range("T1:U" & Total_Lineas_T)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    ' -8- Como tengo las dos columnas ordenadas A y T voy recorriendo
    '     las dos columnas de forma secuencial para comparar.
    '
    '     Si son iguales Tomo el valor de la columna B que es el mismo que el
    '     de la columna J de la Hoja2 para el mismo codigo de las columna A
    '     aunque este en diferente linea.
    '
    '     Y lo copio a la columna U de la hoja1 en la fila que esta el codigo
    '     de la columna T en la hoja1 que es lo que me indica el número de la
    '     columna U de la nueva Hoja
 
    Fila_A = 2   ' -- Esta es la columna A de la hoja2
    Fila_T = 2   ' -- Esta es la Columna T de la hoja1
    Fin = 0
 
    While Fin = 0
        Codigo_A = Cells(Fila_A, 1)
        Codigo_T = Cells(Fila_T, 20)
 
        If Codigo_A = Codigo_T Then
           Sheets(New_Hoja).Range("B" & Fila_A).Copy Sheets("Hoja1").Range("U" & Cells(Fila_T, 21))
           Fila_A = Fila_A + 1
        Else
           If Codigo_A < Codigo_T Then
              Fila_A = Fila_A + 1
           Else
              Fila_T = Fila_T + 1
           End If
        End If
 
        If Fila_A > Total_Lineas_A Then Fin = 1
        If Fila_T > Total_Lineas_T Then Fin = 1
    Wend
 
    ' -9- Y una vez finalizado ELIMINO la nueva hoja
 
    Sheets(New_Hoja).Select
    ActiveWindow.SelectedSheets.Delete
 
    MsgBox "MACRO Finalizada" & vbCrLf & vbCrLf & _
           "Tiempo de ejecucion: " & Format(Timer - Inicio, "#.## seg."), _
           vbInformation + vbOKOnly, "M A C R O"
End Sub

Cuando finalice la macro sale un mensaje y te dice el tiempo que tardo.

Saludos.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana

Macro para copiar celdas de forma rapida

Publicado por Antoni Masana amasana@hotmail.com (47 intervenciones) el 18/08/2016 08:12:02
Buenos días Javier.

¿Cuenta que tal la macro que te envie?

¿Cuanto tarda en ejecutarse?

¿Que opinión te merece?

Tengo curiosidad por saber que tan rápido es y si funciona correctamente.


Saludos
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana

Macro para copiar celdas de forma rapida

Publicado por Antoni Masana (47 intervenciones) el 19/08/2016 06:29:49
He realizado una simulación con más de 800000 datos.

En la hoja1 hay 998319 lineas y en la hoja2 987193 líneas. El tiempo de ejecución es de 32826.34 segundos que son 09:07:06 horas.
Pero tiene una pega y es que se bloquea el equipo mientras calcula. Hay que poner un comando en una parte del código para que no se bloque.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
While Fin = 0
        Codigo_A = Cells(Fila_A, 1)
        Codigo_T = Cells(Fila_T, 20): DoEvents
 
        If Codigo_A = Codigo_T Then
           Sheets(New_Hoja).Range("B" & Fila_A).Copy Sheets("Hoja1").Range("U" & Cells(Fila_T, 21))
           Fila_A = Fila_A + 1
        Else
           If Codigo_A < Codigo_T Then
              Fila_A = Fila_A + 1
           Else
              Fila_T = Fila_T + 1
           End If
        End If
 
        If Fila_A > Total_Lineas_A Then Fin = 1
        If Fila_T > Total_Lineas_T Then Fin = 1
    Wend

Quizas tarde un poco más pero trabaja en segundo plano.

Saludos
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar