Excel - PROCESO LENTO

hola Juanc
espero que me tengas paciencia, he estado probando los codigos que mensionaste
pero me marca errores.¿me puedes ayudar un poco mas por favor?

Atte.

Catita Zarate

hoja("3.6.6")

ALMACEN UBICACIÓN CODIGO DESCRIPCION CANTIDAD

400--------- 101->400--- 415123--- YOG ACTIV CIRUELA 120 GRC 840.00
300---------- 200->300-- 415222----- ACTIVIA LIGHT FRUTI 120GC 720
200--------- 101->200----430674----- FLAN DIET VAINILL 24x120C 0.00
100--------- cccc01------- 100103----- LECHE UHT NATURAL 12x1CAJ 734.00
200--------- REF---------- 100160----- SOFT SERV MCD VAIN 12x1CA 3,058.00
100--------- cccc01------ 100554----- LECHE UHT SEMIDESCR 12x1C 449.00
500--------- aba---------- -120116----- LECHE UHT CHOCOL 30x200CA 3,033.00
100--------- cccc01------ 120116----- LECHE UHT CHOCOL 30x200CA 17.00
300---------- ABA--------- 120116----- LECHE UHT CHOCOL 30x200CA 3,017.00
100---------- cccc01------ 120116----- LECHE UHT CHOCOL 30x200CA 3,081.00
200---------- ref------------ 120116----- LECHE UHT CHOCOL 30x200CA 35.00
400---------- REF01------ 120116---- LECHE UHT CHOCOL 30x200CA 3,079.00
100---------- cccc01------ 120116----- LECHE UHT CHOCOL 30x200CA 2,792.00
100--------- cccc01------ --120116---- LECHE UHT CHOCOL 30x200CA 2,926.00
100---------- cccc01------ 120121---- LECHE UHT FRUTILL 30x200C 4,454.00
500---------- 101->500-- 120121---- LECHE UHT FRUTILL 30x200C 374.00
101---------- aa0101----- 120121---- LECHE UHT FRUTILL 30x200C 4,596.00
200---------- puth01----- 120121---- LECHE UHT FRUTILL 30x200C 3,783.00
100---------- cccc01------ 120261---- LE UHT CHOC LIGHT 30x200C 3,059.00
300---------- REF--------- 120623---- LECH UHT CHOC LIGHT 12x1C 1,561.00
100---------- cccc01------ 120624---- LECHE UHT CHOCOLATE 12x1C 2,368.00
300---------- ABA---------- 120624---- LECHE UHT CHOCOLATE 12x1C 2,373.00
101---------- b4001------- 120628---- LECH UHT FRUT LIGHT 12x1C 1,464.00
100---------- cccc01------ 140373---- CREMA UHT LIGHT 30x200CAJ 11.00
400---------- REF03------ 140564----- CREMA UHT 35% MG 12x1CAJA 749

hoja("STOCK & DEMANDA")

Cod_Art.----- Descripcion

100103 -------LECHE UHT NATURAL 12x1CAJ
100155 -------SOFT SERV MCD CHOC 12x1CA
100160 -------SOFT SERV MCD VAIN
100161 -------SOFT S. MCD VAIN 5% 12x1C
100200 -------MEZ HELADO VAINILLA 12x1C
100201------- MEZ HELADO CHOCOL 12x1CAJ
120116 ------LECHE UHT CHOCOL 30x200CA
120121 ------LECHE UHT FRUTILL 30x200C
120130 ------LECHE UHT MOKKA L 30x200
120131 ------LECHE UHT CAPPUCC 30x200
120132 ------LECHE UHT CARAMEL L 30x200
120261 ------LE UHT CHOC LIGHT 30x200C
120262 ------LE UHT FRUT LIGHT 30x200C
120623 -----LECH UHT CHOC LIGHT 12x1C
120624 -----LECHE UHT CHOCOLATE 12x1C
120627 -----LECHE UHT FRUTILLA 12x1CA
120628 -----LECH UHT FRUT LIGHT 12x1C
120630 -----LECHE UHT MOKKA LAT 12x1C
120631 -----LECHE UHT CAPUCCINO 12x1C
120632 -----LECHE UHT CARAMEL 12x1CAJ
140371 -----CREMA UHT PARM 30x200
140373 -----CREMA UHT LIGHT 30x200
140564 -----CREMA UHT 35% MG 12x1CAJA
180565 -----LECHE COND AZUC 48x396grC
210201 -----NECTAR UHT NARANJ 30x200C
210206 -----NECTAR UHT PINA 30x200CAJ
210211----- NECTAR UHT MANZAN 30x200C
210215 ----NECTAR UHT DAMASCO 12x1
210216 ----NECTAR UHT DAMASC 30x200
210220 ----NECTAR UHT DURAZNO 12x1
210221----- NECTAR UHT DURAZN 30x200

los codigo que estoy probando son de 2 formas, y son los siguientes :
con este codigo nunca termina de efectuarse el proceso.

Sub test()
Dim C As Range, D As Range, SUM&, SUMAR&, SUMA&
With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set MIRANGO = Worksheets("STOCK & DEMANDA").[A6:C200]
Set ELRANGO = Worksheets("3.6.6").[N7:R4000]
For Each D In MIRANGO
SUM = 0
SUMA=0
SUMAR = 0
For Each C In ELRANGO
If Cells(C.Row, 14).Value = "101" And (Cells(C.Row, 15).Value = "ptre02" Or _
Cells(C.Row, 15).Value = "ref53" Or Cells(C.Row, 15).Value = "ptuh01" Or _
Cells(C.Row, 15).Value = "aba" Or Cells(C.Row, 15).Value = "ref01" Or _
Cells(C.Row, 15).Value = "ref" Or Cells(C.Row, 15).Value = "ref02" Or _
Cells(C.Row, 15).Value = "aa0101" Or Cells(C.Row, 15).Value = "ref1387" Or _
Cells(C.Row, 15).Value = "ba0101" Or Cells(C.Row, 15).Value = "a0101" Or _
Cells(C.Row, 15).Value = "c0101" Or Cells(C.Row, 15).Value = "a9901" Or _
Cells(C.Row, 15).Value = "b4001") And Cells(C.Row, 16).Value = Cells(D.Row, 1).Value Then
SUM = SUM + Cells(C.Row, 18).Value
Cells(D.Row, 5).Value = SUM

ElseIf Cells(C.Row, 14).Value = "100" And Cells(C.Row, 15).Value = "cccc01" _
And Cells(C.Row, 16).Value = Cells(D.Row, 1).Value Then
SUMA = SUMA + Cells(C.Row, 18).Value
Cells(D.Row, 7).Value = SUMA

ElseIf Cells(C.Row, 14).Value = "200" And (Cells(C.Row, 15).Value = "ABA" Or _
Cells(C.Row, 15).Value = "ptre02" Or Cells(C.Row, 15).Value = "REF" Or _
Cells(C.Row, 15).Value = "ref53" Or Cells(C.Row, 15).Value = "ptuh01" Or _
Cells(C.Row, 15).Value = "aba" Or Cells(C.Row, 15).Value = "ref01" Or _
Cells(C.Row, 15).Value = "ref" Or Cells(C.Row, 15).Value = "ref02" Or _
Cells(C.Row, 15).Value = "aa0101" Or Cells(C.Row, 15).Value = "ref1387" Or _
Cells(C.Row, 15).Value = "ba0101" Or Cells(C.Row, 15).Value = "a0101" Or _
Cells(C.Row, 15).Value = "c0101" Or Cells(C.Row, 15).Value = "a9901" Or _
Cells(C.Row, 15).Value = "b4001") And Cells(C.Row, 16).Value = Cells(D.Row, 1).Value Then
SUMAR = SUMAR + Cells(C.Row, 18).Value
Cells(D.Row, 8).Value = SUMAR
End If
Next C
Next D
With Application
.ScreenUpdating = True
.Calculation = old
.EnableEvents = True
End With

End Sub

con este codigo me enuncia error "subindice fuera del intervalo"
Sub test()
Dim MX As Variant, MAX As Variant
Dim I&, J&, M&, N&, R&, S&
Dim RNG As Range, RBD As Range

With Application
.ScreenUpdating = False
old = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
Set RNG = [A1:B200]
With RNG
M = .Rows.Count
'N = .Columns.Count
MAX = .Value
End With
Set RBD = Worksheets("3.6.6").[N7:R4000]
With RBD
R = .Rows.Count
'S = .Columns.Count
MX = .Value
End With
For J = 6 To M
'I = 7
SUM = 0
SUMA = 0
SUMAR = 0
SUMAR1 = 0
SUMAR2 = 0
SUMAR3 = 0
SUMARSE = 0
SUMARSE1 = 0
SUMARSE2 = 0
SUMARSE3 = 0
For I = 7 To R
If MX(I, 14) = "101" And (MX(I, 15) = "ptre02" Or _
MX(I, 15) = "ref53" Or MX(I, 15) = "ptuh01" Or _
MX(I, 15) = "aba" Or MX(I, 15) = "ref01" Or _
MX(I, 15) = "ref" Or MX(I, 15) = "ref02" Or _
MX(I, 15) = "aa0101" Or MX(I, 15) = "ref1387" Or _
MX(I, 15) = "ba0101" Or MX(I, 15) = "a0101" Or _
MX(I, 15) = "c0101" Or MX(I, 15) = "a9901" Or _
MX(I, 15) = "b4001") And MX(I, 16) = MAX(J, 1) Then
SUM = SUM + MX(I, 18)
MAX(J, 5) = SUM

ElseIf MX(I, 14).Value = "100" And MX(I, 15) = "cccc01" _
And MX(I, 16).Value = MAX(J, 1) Then
SUMA = SUMA + MX(I, 18)
MAX(J, 7) = SUMA

ElseIf MX(I, 14) = "200" And (MX(I, 15) = "ptre02" Or _
MX(I, 15) = "ref53" Or MX(I, 15) = "ptuh01" Or _
MX(I, 15) = "aba" Or MX(I, 15) = "ref01" Or _
MX(I, 15) = "ref" Or MX(I, 15) = "ref02" Or _
MX(I, 15) = "aa0101" Or MX(I, 15) = "ref1387" Or _
MX(I, 15) = "ba0101" Or MX(I, 15) = "a0101" Or _
MX(I, 15) = "c0101" Or MX(I, 15) = "a9901" Or _
MX(I, 15) = "b4001") And MX(I, 16) = MAX(J, 1) Then
SUMAR = SUMAR + MX(I, 18)
MAX(J, 8) = SUMAR

ElseIf MX(I, 14) = "300" And (MX(I, 15) = "ptre02" Or _
MX(I, 15) = "ref53" Or MX(I, 15) = "ptuh01" Or _
MX(I, 15) = "aba" Or MX(I, 15) = "ref01" Or _
MX(I, 15) = "ref" Or MX(I, 15) = "ref02" Or _
MX(I, 15) = "aa0101" Or MX(I, 15) = "ref1387" Or _
MX(I, 15) = "ba0101" Or MX(I, 15) = "a0101" Or _
MX(I, 15) = "c0101" Or MX(I, 15) = "a9901" Or _
MX(I, 15) = "b4001") And MX(I, 16) = MAX(J, 1) Then
SUMAR1 = SUMAR1 + MX(I, 18)
MAX(J, 13) = SUMAR1

ElseIf MX(I, 14) = "400" And (MX(I, 15) = "ptre02" Or _
MX(I, 15) = "ref53" Or MX(I, 15) = "ptuh01" Or _
MX(I, 15) = "aba" Or MX(I, 15) = "ref01" Or _
MX(I, 15) = "ref" Or MX(I, 15) = "ref02" Or _
MX(I, 15) = "aa0101" Or MX(I, 15) = "ref1387" Or _
MX(I, 15) = "ba0101" Or MX(I, 15) = "a0101" Or _
MX(I, 15) = "c0101" Or MX(I, 15) = "a9901" Or _
MX(I, 15) = "b4001") And MX(I, 16) = MAX(J, 1) Then
SUMAR2 = SUMAR2 + MX(I, 18)
MAX(J, 18) = SUMAR2

ElseIf MX(I, 14) = "500" And (MX(I, 15) = "ptre02" Or _
MX(I, 15) = "ref53" Or MX(I, 15) = "ptuh01" Or _
MX(I, 15) = "aba" Or MX(I, 15) = "ref01" Or _
MX(I, 15) = "ref" Or MX(I, 15) = "ref02" Or _
MX(I, 15) = "aa0101" Or MX(I, 15) = "ref1387" Or _
MX(I, 15) = "ba0101" Or MX(I, 15) = "a0101" Or _
MX(I, 15) = "c0101" Or MX(I, 15) = "a9901" Or _
MX(I, 15) = "b4001") And MX(I, 16) = MAX(J, 1) Then
SUMAR3 = SUMAR3 + MX(I, 18)
MAX(J, 23) = SUMAR3

ElseIf MX(I, 14) = "200" And _
MX(I, 15) = "101->200" And MX(I, 16) = MAX(J, 1) Then
SUMARSE = SUMARSE + MX(I, 18)
MAX(J, 12) = SUMARSE

ElseIf MX(I, 14) = "300" And _
(MX(I, 15) = "101->300" Or MX(I, 15) = "200->300") And _
MX(I, 16) = MAX(J, 1) Then
SUMARSE1 = SUMARSE1 + MX(I, 18)
MAX(J, 17) = SUMARSE1

ElseIf MX(I, 14) = "400" And _
(MX(I, 15) = "101->400" Or MX(I, 15) = "200->400") And _
MX(I, 16) = MAX(J, 1) Then
SUMARSE2 = SUMARSE2 + MX(I, 18)
MAX(J, 22) = SUMARSE2

ElseIf MX(I, 14) = "500" And _
(MX(I, 15) = "101->500" Or MX(I, 15) = "200->500") And _
MX(I, 16) = MAX(J, 1) Then
SUMARSE3 = SUMARSE3 + MX(I, 18)
MAX(J, 27) = SUMARSE3

End If
Next I
Next J
With Application
.ScreenUpdating = True
.Calculation = old
.EnableEvents = True
End With

End Sub

Hola, te doy mi opinion. Es mas facil trabajar con tabla dinamica. Puedes orobar esto.

Espero tu respuesta

Un saludo desde Ambato, Ecuador
SCM

no es buena idea la tabla dinamica, porque estoy manejando muchas informaciones de lo contrario tendria que estar filtrando permanentemente
para observar distintos datos, y lo que yo quiero es verlos todo a la vez, por lo tanto necesito optimizar mi macro para que el proceso sea mas rapido.

si alguien tuviera un codigo adaptado al que envie para que el proceso sea mas rapido se lo agradeceria.

Atte.

Catita Zarate

Catita, disculpame que ahora no te pueda dar una mano con el código, tengo
demasiadas cosas por hacer...

Saludos desde Baires, JuanC

Hola JuanC

voy a estar esperando tu ayuda apenas te desocupes, por lo pronto voy a seguir
procesando mis datos con el codigo antiguo que lo he mejorado y el tiempo de ejecucion a bajado de 5 a 2 minutos, aunque lo ideal seria como maximo 30 segundos.
aqui les mando el codigo actual

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim filaQ%, filaP%, SUM&, filaX%, old&, sVal$, SUMA&, SUMAR&, SUMARSE&, SUMARSE1&, SUMARSE2&
Dim SUMARSE3&, SUMAR1&, SUMAR2&, SUMAR3&

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
SUMA = 0
SUMAR = 0
SUMAR1 = 0
SUMAR2 = 0
SUMAR3 = 0
SUMARSE = 0
SUMARSE1 = 0
SUMARSE2 = 0
SUMARSE3 = 0
filaQ = 7
While .Cells(filaQ, 16).Value <> ""
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
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&

ElseIf .Cells(filaQ, 14).Value = "100" And sVal = "cccc01" _
And .Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then
SUMA = SUMA + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 7).Value = SUMA
'@@@@@@@@@@@@@@@@@@@@@@@@@@

ElseIf .Cells(filaQ, 14).Value = "200" Then
If (sVal = "ABA" Or _
sVal = "ptre02" Or sVal = "REF" 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
SUMAR = SUMAR + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 8).Value = SUMAR
ElseIf sVal = "101->200" And .Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then
SUMARSE = SUMARSE + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 12).Value = SUMARSE
End If
'ÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇÇ

ElseIf .Cells(filaQ, 14).Value = "300" Then
If (sVal = "ABA" Or _
sVal = "ptre02" Or sVal = "REF" 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
SUMAR1 = SUMAR1 + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 13).Value = SUMAR1
ElseIf (sVal = "101->300" Or sVal = "200->300") And _
.Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then
SUMARSE1 = SUMARSE1 + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 17).Value = SUMARSE1
End If
'(((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((((

ElseIf .Cells(filaQ, 14).Value = "400" Then
If (sVal = "ABA" Or _
sVal = "ptre02" Or sVal = "REF" 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
SUMAR2 = SUMAR2 + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 18).Value = SUMAR2
ElseIf (sVal = "101->400" Or sVal = "200->400") And _
.Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then
SUMARSE2 = SUMARSE2 + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 22).Value = SUMARSE2
End If
')))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))

ElseIf .Cells(filaQ, 14).Value = "500" Then
If (sVal = "ABA" Or _
sVal = "ptre02" Or sVal = "REF" 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
SUMAR3 = SUMAR3 + .Cells(filaQ, 18).Value
ws1.Cells(filaX, 23).Value = SUMAR3
ElseIf (sVal = "101->500" Or sVal = "200->500") And _
.Cells(filaQ, 16).Value = ws1.Cells(filaX, 1).Value Then
SUMARSE3 = SUMARSE3 + .Cells(filaQ, 18).Value
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

si tuviera a mano el archivo podría optimizarlo más, pero bueno, es lo que hay!

Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim filaQ%, filaP%, SUM&, filaX%, old&, sVal$
Dim SUMA&, SUMAR&, SUMARSE&, SUMARSE1&, SUMARSE2&
Dim SUMARSE3&, SUMAR1&, SUMAR2&, SUMAR3&
Dim Q14, Q16, Q18, 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 = 6
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
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

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 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 (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 (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 (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

Saludos desde Baires, JuanC