Optimizar una Macro

[hans123]

Estimados,

Soy nuevo en este foro y desde ya agradezco la creación en este foro, sus importantes aportes y la ayuda que me puedan brindar.

Necesito que me puedan ayudar por favor, en la optimización de una macro (realizada en Excel 2007) , ya que, se demora bastante tiempo en ejecutarla y como la ocupo varias veces al día se me hace MUY necesario el poder hacer que corra mas rápido.

He probado con distintos códigos, entre ellos, agregar al inicio y al final de la macro, las siguientes sentencias.

Al inicio:

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

Al final:

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

Application.CutCopyMode = False

Entre otras cosas, pero NADA me resulta... el proceso se sigue demorando aproximadamente 20 minutos.

Así que les pido de favor que me puedan ayudar!!

Muchas Gracias!

PD: Les adjunto el código:

Public Const hoja_macro As Integer = 1 ' numero (indice) de la hoja macro

Public Const hoja_frecuencia As Integer = 2 'numero (indice) de la hoja frecuencia

Public Const hoja_velocidad As Integer = 3 'numero (indice) de la hoja velocidad

Public Const hoja_distancia As Integer = 4 'numero (indice) de la hoja ditancia

Public Const hoja_capacidad As Integer = 5 'numero (indice) de la hoja capacidad

Public Const hoja_flota As Integer = 6 'numero (indice) de la hoja flota

Public Const max_servicio As Integer = 800 ' maxima cantidad de servicios del sistema

Public Const max_periodo As Integer = 29 ' cantidad de periodos

' funcion que retorna la fila donde se encuentra el servicio buscado

Function buscar_ss(servicio As String, sentido As String, indice_hoja As Integer)

For i = 1 To max_servicio

If UCase(Sheets(indice_hoja).Cells(i, 2)) = UCase(servicio) And UCase(Sheets(indice_hoja).Cells(i, 3)) = UCase(sentido) Then

buscar_ss = i

Exit Function

End If

Next

End Function

Sub traspone()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

Application.EnableEvents = False

ActiveSheet.DisplayPageBreaks = False

limpiar ' funcion para limpiar datos de hoja macro

fila = 2 ' para ir escribiendo a partir de la fila 2 en hoja macro

For i = 1 To max_servicio ' recorrer filas hasta el maximo de servicios definidos

For j = 1 To max_periodo ' recorrer columnas hasta la cantidad de periodos definidos

If Sheets(hoja_frecuencia).Cells(i + 6, 1) <> "" Then ' recorrer filas hasta pillar celda vacio, lo que significa que no hay mas datos

'aqu se va rellenando fila por fila la informacion en la hoja macro

'///////////////////////////////////////////

Sheets(hoja_macro).Cells(fila, 1) = Sheets(hoja_frecuencia).Cells(i + 6, 1) ' unidad

Sheets(hoja_macro).Cells(fila, 2) = Sheets(hoja_frecuencia).Cells(i + 6, 2) ' servicio

Sheets(hoja_macro).Cells(fila, 3) = Sheets(hoja_frecuencia).Cells(i + 6, 3) ' sentido

Sheets(hoja_macro).Cells(fila, 4) = Sheets(hoja_frecuencia).Cells(1, j + 3) ' periodo

Sheets(hoja_macro).Cells(fila, 5) = Sheets(hoja_frecuencia).Cells(buscar_ss(Sheets(hoja_frecuencia).Cells(i + 6, 2), Sheets(hoja_frecuencia).Cells(i + 6, 3), 2), j + 3)

Sheets(hoja_macro).Cells(fila, 6) = Sheets(hoja_velocidad).Cells(buscar_ss(Sheets(hoja_frecuencia).Cells(i + 6, 2), Sheets(hoja_frecuencia).Cells(i + 6, 3), 3), j + 3)

Sheets(hoja_macro).Cells(fila, 7) = Sheets(hoja_distancia).Cells(buscar_ss(Sheets(hoja_frecuencia).Cells(i + 6, 2), Sheets(hoja_frecuencia).Cells(i + 6, 3), 4), j + 3)

Sheets(hoja_macro).Cells(fila, 8) = Sheets(hoja_capacidad).Cells(buscar_ss(Sheets(hoja_frecuencia).Cells(i + 6, 2), Sheets(hoja_frecuencia).Cells(i + 6, 3), 5), j + 3)

Sheets(hoja_macro).Cells(fila, 9) = Sheets(hoja_flota).Cells(buscar_ss(Sheets(hoja_frecuencia).Cells(i + 6, 2), Sheets(hoja_frecuencia).Cells(i + 6, 3), 6), j + 3)

fila = fila + 1

End If

Next

Next

MsgBox "proceso terminado con exito !! revisa resultados"

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

Application.EnableEvents = True

ActiveSheet.DisplayPageBreaks = True

Application.CutCopyMode = False

End Sub

Sub limpiar() ' funcion para limpiar datos de la hoja macro

'

' limpiar Macro

'

'

Range("A2:I2").Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Range(Selection, Selection.End(xlDown)).Select

Selection.ClearContents

End Sub

' funcion para agregar letra T a los troncales

Sub formato()

For i = 1 To 23000

If Sheets(hoja_macro).Cells(i, 1) Like "*T*" Then

Sheets(hoja_macro).Cells(i, 2) = "T" & Sheets(hoja_macro).Cells(i, 2)

End If

Next

End Sub

[Antoni]

Sin archivo es como "cascarsela" a un muerto.