Excel - PROCESO LENTO

JuanC

gracias por tu aporte logre reducir aun mas el tiempo del proceso, pero me gustaria enviarte el archivo para optimizarlo mas.si no es mucho pedir cual es tu correo para enviartelo
como veras estoy utilizando otro correo porque el mio tiene problemas

aprovecho de pregunterte algo al respecto te envio el codigo adaptado al archivo

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim filaQ%, filaQQ%, filaX%, filaQQQ%, filaQQQQ%, filaQQQQQ%, filaP%, SUM&, old&, sVal$, SUMA&, SUMAR&, SUMARSE&, SUMARSE1&, SUMARSE2&
Dim SUMARSE3&, SUMAR1&, SUMAR2&, SUMAR3&
Dim Q14, Q16, Q18, Q17, X1 '//Declaradas como Variant
With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set ws1 = Worksheets("STOCK & DEMANDA")
Set ws2 = Worksheets("3.6.6")
filaX = 12
With ws2
While ws1.Cells(filaX, 1).Value <> ""
SUM = 0: SUMA = 0
SUMAR = 0: SUMAR1 = 0
SUMAR2 = 0: SUMAR3 = 0
SUMARSE = 0: SUMARSE1 = 0
SUMARSE2 = 0: SUMARSE3 = 0
filaQ = 7: filaQQ = 7
filaQQQ = 7: filaQQQQ = 7
filaQQQQQ = 7:
X1 = ws1.Cells(filaX, 1).Value

While .Cells(filaQ, 16).Value <> ""
sVal = .Cells(filaQ, 15).Value
Q14 = .Cells(filaQ, 14).Value
Q16 = .Cells(filaQ, 16).Value
Q18 = .Cells(filaQ, 18).Value
Q17 = .Cells(filaQ, 17).Value
If Q14 = "101" And tt("101", sVal) And Q16 = X1 Then
SUM = SUM + Q18
ws1.Cells(filaX, 5).Value = SUM
ElseIf Q14 = "100" And sVal = "cccc01" And Q16 = X1 Then
SUMA = SUMA + Q18
ws1.Cells(filaX, 7).Value = SUMA
ElseIf Q14 = "200" Then
If tt("200", sVal) And Q16 = X1 Then
SUMAR = SUMAR + Q18
ws1.Cells(filaX, 8).Value = SUMAR
ElseIf ttt("200", sVal) And Q16 = X1 Then
.Cells(filaQQ, 20).Value = Q14
.Cells(filaQQ, 21).Value = sVal
.Cells(filaQQ, 22).Value = Q16
.Cells(filaQQ, 23).Value = Q17
.Cells(filaQQ, 24).Value = Q18
filaQQ = filaQQ + 1

ElseIf sVal = "101->200" And Q16 = X1 Then
SUMARSE = SUMARSE + Q18
ws1.Cells(filaX, 12).Value = SUMARSE
End If
ElseIf Q14 = "300" Then
If tt("300", sVal) And Q16 = X1 Then
SUMAR1 = SUMAR1 + Q18
ws1.Cells(filaX, 13).Value = SUMAR1
ElseIf ttt("300", sVal) And Q16 = X1 Then
.Cells(filaQQQ, 25).Value = Q14
.Cells(filaQQQ, 26).Value = sVal
.Cells(filaQQQ, 27).Value = Q16
.Cells(filaQQQ, 28).Value = Q17
.Cells(filaQQQ, 29).Value = Q18
filaQQQ = filaQQQ + 1

ElseIf (sVal = "101->300" Or sVal = "200->300") And _
Q16 = X1 Then
SUMARSE1 = SUMARSE1 + Q18
ws1.Cells(filaX, 17).Value = SUMARSE1
End If
ElseIf Q14 = "400" Then
If tt("400", sVal) And Q16 = X1 Then
SUMAR2 = SUMAR2 + Q18
ws1.Cells(filaX, 18).Value = SUMAR2
ElseIf ttt("400", sVal) And Q16 = X1 Then
.Cells(filaQQQQ, 30).Value = Q14
.Cells(filaQQQQ, 31).Value = sVal
.Cells(filaQQQQ, 32).Value = Q16
.Cells(filaQQQQ, 33).Value = Q17
.Cells(filaQQQQ, 34).Value = Q18
filaQQQQ = filaQQQQ + 1
ElseIf (sVal = "101->400" Or sVal = "200->400") And _
Q16 = X1 Then
SUMARSE2 = SUMARSE2 + Q18
ws1.Cells(filaX, 22).Value = SUMARSE2
End If
ElseIf Q14 = "500" Then
If tt("500", sVal) And Q16 = X1 Then
SUMAR3 = SUMAR3 + Q18
ws1.Cells(filaX, 23).Value = SUMAR3
ElseIf ttt("500", sVal) And Q16 = X1 Then
.Cells(filaQQQQQ, 35).Value = Q14
.Cells(filaQQQQQ, 36).Value = sVal
.Cells(filaQQQQQ, 37).Value = Q16
.Cells(filaQQQQQ, 38).Value = Q17
.Cells(filaQQQQQ, 39).Value = Q18
filaQQQQQ = filaQQQQQ + 1

ElseIf (sVal = "101->500" Or sVal = "200->500") And _
Q16 = X1 Then
SUMARSE3 = SUMARSE3 + Q18
ws1.Cells(filaX, 27).Value = SUMARSE3
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

Private Function tt(ByVal sCode As String, ByVal sVal As String) As Boolean
Select Case sCode
Case "101"
tt = InStr(1, "ptre02,ref53,ptuh01,aba,ref01,ref,ref02,aa0101,ref1387,ba0101,a0101,c0101,a9901,b4001,", sVal & ",") > 0
Case "200", "300", "400", "500"
tt = InStr(1, "ABA,ptre02,REF,ref53,ptuh01,aba,ref01,ref,ref02,aa0101,ref1387,ba0101,a0101,c0101,a9901,b4001,", sVal & ",") > 0
End Select
End Function

Private Function ttt(ByVal sCode As String, ByVal sVal As String) As Boolean
Select Case sCode
Case "200", "300", "400", "500"
ttt = InStr(1, "austral,emilia,caroca,montano,retenido,arranz,lts,super10,uyv,dys,dym,tottus,sisabri,adelco,mac,vega,alvi,tomas,laoferta,lafama,jumbo,junaeb,monserrat,stange,solis,monse,", sVal & ",") > 0
End Select
End Function

me seleciona casi todo las reservas menos adelco, austral, emilia, laoferta..porque..?

Atte.

CatitaZarate.

Hola, bueno puedes enviarme tu archivo por el correo para que yo modifique la mejora de tiempo.

mi correo es [email protected]

Espero que me mandes por el correo :-)