Excel - Proceso lento:Buscar y Cargar

Amigos:

La macro que estoy trabajando tiene el proceso lento

Es asi como funciona esta macro:

En la HOJA("control transporte") tengo codigos de rutas entre las columnas N:U y la fecha en U3, estos codigos y fecha se deben buscar en la base de dato HOJA("base") en la columna AE y Q, de coincidir ambos se deben sumar los kilos de la columna C y pegar en la columna X de la HOJA("control transporte").

En la columna W de la HOJA("control transporte") se deben pegar los kilos de la HOJA("BASE") de la columna A, siempre en cuando los codigos de ambas HOJAS sean iguales y la fecha de U3 sea distinto en la HOJA("base") de la columna L y la columna K sea distinto a espacio en blanco y N sea igual a espacio en blanco.

Por favor, si alguien tuviera una mejor idea como optimizarlo se le agradece

Este es el codigo:

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim old&, FILAA&, FILA1&, Kilos#, FilaB&
Dim WS1 As Worksheet, WS2 As Worksheet, Col&, Fil&, Cero&, Kil#
If Target.Address(False, False) = "X4" Then
Worksheets("Control Transporte").Range("X5:X135").Value = Empty
Worksheets("Control Transporte").Range("W5:W135").Value = Empty
With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set WS1 = Worksheets("Control Transporte")
Set WS2 = Worksheets("base")
FilaB = 2
While WS2.Cells(FilaB, 9).Value <> ""
FilaB = FilaB + 1
Wend

For Fil = 9 To 130
Kil = 0#
Kilos = 0#
For Col = 14 To 21
If WS1.Cells(Fil, Col).Value <> "" Then
For FILA1 = 2 To FilaB
If LCase(WS1.Cells(Fil, Col).Value) = LCase(WS2.Cells(FILA1, 31).Value) Then
If WS1.Cells(3, 21).Value = WS2.Cells(FILA1, 17).Value Then
Kilos = Kilos + WS2.Cells(FILA1, 3).Value
ElseIf WS1.Cells(3, 21).Value <> WS2.Cells(FILA1, 12).Value And WS2.Cells(FILA1, 11).Value <> Empty _
And WS2.Cells(FILA1, 14).Value = Empty Then
Kil = Kil + WS2.Cells(FILA1, 1).Value
End If
End If
Next FILA1
End If
WS1.Cells(Fil, 24).Value = Kilos
WS1.Cells(Fil, 24).Interior.ColorIndex = 36
WS1.Cells(Fil, 24).Font.ColorIndex = 5
WS1.Cells(Fil, 24).Font.Bold = True

WS1.Cells(Fil, 23).Value = Kil
WS1.Cells(Fil, 23).Interior.ColorIndex = 36
WS1.Cells(Fil, 23).Font.ColorIndex = 3
WS1.Cells(Fil, 23).Font.Bold = True
Next Col
Next Fil

'Las filas que no tengan Rutas se limpiaran para evitar la cantidad cero
For Cero = 9 To 130
If WS1.Cells(Cero, 22).Value = "" And WS1.Cells(Cero, 24).Value = "0" Then
WS1.Cells(Cero, 24).Value = ""
End If
If WS1.Cells(Cero, 22).Value = "" And WS1.Cells(Cero, 23).Value = "0" Then
WS1.Cells(Cero, 23).Value = ""
End If
Next Cero

With Application
.ScreenUpdating = True
.Calculation = old
.EnableEvents = True
End With

Set WS1 = Nothing
Set WS2 = Nothing
Range("J1").Select
With Selection.Font
.Name = "Old English Text MT"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.ColorIndex = 36
ActiveCell.FormulaR1C1 = "Catalina Zarate R"
Range("J6").Select
End If
End Sub


Atte.

Catita Z. R.

Amigos:

Nuevamente con el consejo y la ayuda de JuanC, se logro reducir el tiempo del proceso hasta en un 55%

'Usando el FOR EACH

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim old&, FILAA&, FILA1&, Kilos#, FilaB&
Dim WS1 As Worksheet, WS2 As Worksheet, Col&, Fil&, Cero&, Kil#
Dim FechDespacho, Rutas
Dim Cell As Range

If Target.Address(False, False) = "X4" Then
Worksheets("Control Transporte").Range("X5:X135").Value = Empty
Worksheets("Control Transporte").Range("W5:W135").Value = Empty
With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Set WS1 = Worksheets("Control Transporte")
Set WS2 = Worksheets("base")

FilaB = 2
While WS2.Cells(FilaB, 9).Value <> ""
FilaB = FilaB + 1
Wend

With WS1
For Fil = 9 To 130
Kil = 0#
Kilos = 0#
For Col = 14 To 21
If .Cells(Fil, Col).Value <> "" Then
FechDespacho = .Cells(3, 21).Value
Rutas = LCase(.Cells(Fil, Col).Value)

For Each Cell In WS2.Range("I2:I" & FilaB - 1)

If Rutas = LCase(Cell.Offset(, 22).Value) Then
If FechDespacho = Cell.Offset(, 8).Value Then
Kilos = Kilos + Cell.Offset(, -6).Value
ElseIf FechDespacho <> Cell.Offset(, 8).Value And Cell.Offset(, 2).Value <> Empty _
And Cell.Offset(, 5).Value = Empty Then
Kil = Kil + Cell.Offset(, -8).Value
End If
End If

Next

End If

.Cells(Fil, 24).Value = Kilos
.Cells(Fil, 24).Interior.ColorIndex = 36
.Cells(Fil, 24).Font.ColorIndex = 5
.Cells(Fil, 24).Font.Bold = True

.Cells(Fil, 23).Value = Kil
.Cells(Fil, 23).Interior.ColorIndex = 36
.Cells(Fil, 23).Font.ColorIndex = 3
.Cells(Fil, 23).Font.Bold = True
Next Col
Next Fil
End With

'Las filas que no tengan Rutas se limpiaran para evitar la cantidad cero
With WS1
For Cero = 9 To 130
If .Cells(Cero, 22).Value = "" And .Cells(Cero, 24).Value = "0" Then
.Cells(Cero, 24).Value = ""
End If
If .Cells(Cero, 22).Value = "" And .Cells(Cero, 23).Value = "0" Then
.Cells(Cero, 23).Value = ""
End If
Next Cero
End With

With Application
.ScreenUpdating = True
.Calculation = old
.EnableEvents = True
End With

Set WS1 = Nothing
Set WS2 = Nothing

Range("J1").Select
With Selection.Font
.Name = "Old English Text MT"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.ColorIndex = 36
ActiveCell.FormulaR1C1 = "Catalina Zarate R"
Range("J6").Select
End If
End Sub

Usando el FOR NEXT

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim old&, FILAA&, FILA1&, Kilos#, FilaB&
Dim WS1 As Worksheet, WS2 As Worksheet, Col&, Fil&, Cero&, Kil#
Dim FechDespacho, Rutas
If Target.Address(False, False) = "X4" Then
Worksheets("Control Transporte").Range("X5:X135").Value = Empty
Worksheets("Control Transporte").Range("W5:W135").Value = Empty
With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set WS1 = Worksheets("Control Transporte")
Set WS2 = Worksheets("base")
FilaB = 2
While WS2.Cells(FilaB, 9).Value <> ""
FilaB = FilaB + 1
Wend

For Fil = 9 To 130
Kil = 0#
Kilos = 0#
For Col = 14 To 21
If WS1.Cells(Fil, Col).Value <> "" Then
FechDespacho = WS1.Cells(3, 21).Value
Rutas = LCase(WS1.Cells(Fil, Col).Value)
For FILA1 = 2 To FilaB
If Rutas = LCase(WS2.Cells(FILA1, 31).Value) Then
If FechDespacho = WS2.Cells(FILA1, 17).Value Then
Kilos = Kilos + WS2.Cells(FILA1, 3).Value
ElseIf FechDespacho <> WS2.Cells(FILA1, 12).Value And WS2.Cells(FILA1, 11).Value <> Empty _
And WS2.Cells(FILA1, 14).Value = Empty Then
Kil = Kil + WS2.Cells(FILA1, 1).Value
End If
End If
Next FILA1
End If
WS1.Cells(Fil, 24).Value = Kilos
WS1.Cells(Fil, 24).Interior.ColorIndex = 36
WS1.Cells(Fil, 24).Font.ColorIndex = 5
WS1.Cells(Fil, 24).Font.Bold = True

WS1.Cells(Fil, 23).Value = Kil
WS1.Cells(Fil, 23).Interior.ColorIndex = 36
WS1.Cells(Fil, 23).Font.ColorIndex = 3
WS1.Cells(Fil, 23).Font.Bold = True
Next Col
Next Fil

'Las filas que no tengan Rutas se limpiaran para evitar la cantidad cero
For Cero = 9 To 130
If WS1.Cells(Cero, 22).Value = "" And WS1.Cells(Cero, 24).Value = "0" Then
WS1.Cells(Cero, 24).Value = ""
End If
If WS1.Cells(Cero, 22).Value = "" And WS1.Cells(Cero, 23).Value = "0" Then
WS1.Cells(Cero, 23).Value = ""
End If
Next Cero

With Application
.ScreenUpdating = True
.Calculation = old
.EnableEvents = True
End With

Set WS1 = Nothing
Set WS2 = Nothing
Range("J1").Select
With Selection.Font
.Name = "Old English Text MT"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.Font.ColorIndex = 36
ActiveCell.FormulaR1C1 = "Catalina Zarate R"
Range("J6").Select
End If
End Sub

Atte.

Catita