Excel - PROCESO LENTO

Hola, amigos
quisiera que me ayudaran, tengo un registro de 5000 filas lo que necesito es rescatar bajo ciertas condiciones una cantidad de registros. pero el proceso es demasiado lento de aprox. 7 minutos, y lo que quiero es el proceso lo mas rapido posible.aqui les mando el codigo que estoy trabajando.

Private Sub Worksheet_Activate()
Dim filaQ As Integer, filaP As Integer, SUM As Long, filaX As Integer
Worksheets("STOCK & DEMANDA").Range("D6:AF180").Value = Empty
filaP = 7

While Worksheets("3.6.6").Cells(filaP, 16).Value <> ""
filaP = filaP + 1
Wend
filaX = 6
While Worksheets("STOCK & DEMANDA").Cells(filaX, 1).Value <> ""
SUM = 0
For filaQ = 7 To filaP
If Worksheets("3.6.6").Cells(filaQ, 14).Value = "101" And (Worksheets("3.6.6").Cells(filaQ, 15).Value = "ptre02" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref53" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ptuh01" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "aba" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref01" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref02" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "aa0101" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref1387" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "ba0101" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "a0101" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "c0101" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "a9901" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "b4001") And Worksheets("3.6.6").Cells(filaQ, 16).Value = Worksheets("STOCK & DEMANDA").Cells(filaX, 1).Value Then
SUM = SUM + Worksheets("3.6.6").Cells(filaQ, 18).Value
Worksheets("STOCK & DEMANDA").Cells(filaX, 5).Value = SUM
End If
Next filaQ
filaX = filaX + 1
Wend
End Sub

espero su ayuda

Prueba con este codigo

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False

Dim filaQ As Integer, filaP As Integer, SUM As Long, filaX As Integer
Worksheets("STOCK & DEMANDA").Range("D6:AF180").Value = Empty
filaP = 7

While Worksheets("3.6.6").Cells(filaP, 16).Value <> ""
filaP = filaP + 1
Wend
filaX = 6
While Worksheets("STOCK & DEMANDA").Cells(filaX, 1).Value <> ""
SUM = 0
For filaQ = 7 To filaP
If Worksheets("3.6.6").Cells(filaQ, 14).Value = "101" And (Worksheets("3.6.6").Cells(filaQ, 15).Value = "ptre02" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref53" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ptuh01" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "aba" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref01" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref02" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "aa0101" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "ref1387" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "ba0101" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "a0101" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "c0101" Or Worksheets("3.6.6").Cells(filaQ, 15).Value = "a9901" Or _
Worksheets("3.6.6").Cells(filaQ, 15).Value = "b4001") And Worksheets("3.6.6").Cells(filaQ, 16).Value = Worksheets("STOCK & DEMANDA").Cells(filaX, 1).Value Then
SUM = SUM + Worksheets("3.6.6").Cells(filaQ, 18).Value
Worksheets("STOCK & DEMANDA").Cells(filaX, 5).Value = SUM
End If
Next filaQ
filaX = filaX + 1
Wend

Application.ScreenUpdating = True

End Sub

Espero que funcione bien :)

Un saludo desde Ambato, Ecuador
SCM

hola:

ese codigo ya lo probe asi de identico, el proceso disminuye solo 1 minuto
pero aun asi sigue siendo lento.

Atte.

Caty

la lentitud del proceso está dada seguramente por los ciclos While Wend
deberías usar ciclos For Each ... In
te dejo el código un poco modificado, no muy optimizado pero más legible...

Private Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim filaQ%, filaP%, SUM&, filaX%, old&, sVal$

With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set ws1 = Worksheets("STOCK & DEMANDA")
Set ws2 = Worksheets("3.6.6")

ws1.Range("D6:AF180").Value = Empty
filaP = 7

While ws2.Cells(filaP, 16).Value <> ""
filaP = filaP + 1
Wend
filaX = 6
With ws2
While ws1.Cells(filaX, 1).Value <> ""
SUM = 0
For filaQ = 7 To filaP
sVal = .Cells(filaQ, 15).Value
If .Cells(filaQ, 14).Value = "101" And (sVal = "ptre02" Or _
sVal = "ref53" Or sVal = "ptuh01" Or _
sVal = "aba" Or sVal = "ref01" Or _
sVal = "ref" Or sVal = "ref02" Or _
sVal = "aa0101" Or sVal = "ref1387" Or _
sVal = "ba0101" Or sVal = "a0101" Or _
sVal = "c0101" Or sVal = "a9901" Or _
sVal = "b4001") And .Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then

SUM = SUM + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 5).Value = SUM
End If
Next filaQ

filaX = filaX + 1
Wend
End With

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

Set ws1 = Nothing
Set ws2 = Nothing
End Sub

Saludos desde Baires, JuanC

hola
lo voy a probar aunque en el codigo que me mandaste, no estas ocupando el FOR EACH NEXT.

despues te cuento como me fue

Atte.

Catita Zarate

hoal JuanC

Realmente me sirvio, le modifique el bucle for y ahora demora la mitad del tiempo anterior.
aun asi disculpa mi insistencia, se puede optimizar aun mas el codigo.

Atte.

Catita Zarate

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim filaQ%, filaP%, SUM&, filaX%, old&, sVal$

With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set ws1 = Worksheets("STOCK & DEMANDA")
Set ws2 = Worksheets("3.6.6")

ws1.Range("D6:AF180").Value = Empty
filaX = 6
With ws2
While ws1.Cells(filaX, 1).Value <> ""
SUM = 0
filaQ = 7
While ws2.Cells(filaQ, 16).Value <> ""
'For filaQ = 7 To filaP
sVal = .Cells(filaQ, 15).Value
If .Cells(filaQ, 14).Value = "101" And (sVal = "ptre02" Or _
sVal = "ref53" Or sVal = "ptuh01" Or _
sVal = "aba" Or sVal = "ref01" Or _
sVal = "ref" Or sVal = "ref02" Or _
sVal = "aa0101" Or sVal = "ref1387" Or _
sVal = "ba0101" Or sVal = "a0101" Or _
sVal = "c0101" Or sVal = "a9901" Or _
sVal = "b4001") And .Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then
SUM = SUM + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 5).Value = SUM
End If
filaQ = filaQ + 1
Wend
filaX = filaX + 1
Wend
End With

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

Set ws1 = Nothing
Set ws2 = Nothing

End Sub

Puedes probar con este codigo. si mejora o no?

SCM

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim filaQ%, filaP%, SUM&, filaX%, old&, sVal$

With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With

Set ws1 = Worksheets("STOCK & DEMANDA")
Set ws2 = Worksheets("3.6.6")

ws1.Range("D6:AF180").Value = Empty

filaX = 6
With ws2
While ws1.Cells(filaX, 1).Value <> ""
SUM = 0
filaQ = 7
While .Cells(filaQ, 16).Value <> ""
'For filaQ = 7 To filaP
sVal = .Cells(filaQ, 15).Value
If .Cells(filaQ, 14).Value = "101" And .Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then
If sVal = "ptre02" Or sVal = "ref53" Or sVal = "ptuh01" Or sVal = "aba" Or sVal = "ref01" Or sVal = "ref" Or sVal = "ref02" Or sVal = "aa0101" Or sVal = "ref1387" Or sVal = "ba0101" Or sVal = "a0101" Or sVal = "c0101" Or sVal = "a9901" Or sVal = "b4001" Then
SUM = SUM + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 5).Value = SUM
End If
End If
filaQ = filaQ + 1
Wend
filaX = filaX + 1
Wend
End With

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

Set ws1 = Nothing
Set ws2 = Nothing

End Sub