Excel - Fil(k) = 1000 * objParcial Mod 1000

Hola, muy buenas noches, me podrian ayudar a revisar el error de la linea 83 por favor.

Datos de la Macro

1 Sub ComponeSuma()
2 '-------------------
3 ' By Cacho Rodríguez
4 '-------------------
5 Dim C As Range, Ini As Long
6 If Not IsNumeric([c3]) Or IsEmpty([c3]) Then Exit Sub
7 If WorksheetFunction.CountBlank(Range([c3], [c1048576].End(xlUp))) > 0 Then
8 MsgBox "El rango de datos contiene" & vbLf & "celdas en blanco."
9 Exit Sub
10 End If
11 With Range([e2], [e1000].End(xlUp))
12 If WorksheetFunction.Count(.Cells) = 0 Then
13 MsgBox "Debe establecer -al menos- un objetivo."
14 Exit Sub
15 End If
16 Application.ScreenUpdating = False
17 .Sort [e2], xlAscending, Header:=xlYes
18 End With
19 Ini = Timer
20 Range("d:d,f:f").ClearContents
21 Hoja2.UsedRange.EntireColumn.Delete Shift:=xlToLeft
22 For Each C In Range([e3], [e2].End(xlDown))
23 Obj = Round(C, 2): Msg = "": ComponeSuma_op
24 Select Case Msg = ""
25 Case True: ToHoja2
26 Case False: C.Offset(, 1) = Msg
27 End Select
28 Next C
29 Set Rng = Nothing
30 With Hoja2
31 Application.GoTo .[a1], True
32 .[a1:a3] = WorksheetFunction.Transpose(Array("Tiempo de", "proceso", Timer - Ini))
33 .[a3].NumberFormat = "0.000 ""seg"""
34 .UsedRange.EntireColumn.AutoFit
35 End With
36 Application.ScreenUpdating = True
37 End Sub
38 Private Sub ToHoja2()
39 Dim j%, k%
40 j = 3: k = 2 + Q
41 With Hoja2.[da1].End(xlToLeft)
42 [e2].Copy .Offset(, 4).Resize(2)
43 .Offset(, 4).Resize(2) = WorksheetFunction.Transpose(Array("Objetivo", Obj))
44 With .Offset(2, 2).Resize(1 + k - j, 3)
45 Range("a" & j, "c" & k).Copy .Cells
46 Range("a" & j, "d" & k).Delete xlShiftUp
47 End With
48 End With
49 End Sub
50 Private Sub ComponeSuma_op()
51 Dim j%, x%, k%, objParcial#
52 Dim Vec1, T%(), U#(), Vec2, Fil
53 If IsEmpty([c3]) Then
54 Msg = "Sin valores que analizar."
55 Exit Sub
56 End If
57 Set Rng = Range([c3], [c2].End(xlDown))
58 'Verifico objetivo fuera de alcance
59 If Round(WorksheetFunction.Sum(Rng), 2) < Obj Then
60 Msg = "El valor objetivo es mayor que la suma de los valores listados."
61 Exit Sub
62 End If
63 'Verifico objetivo mínimo
64 If Round(WorksheetFunction.Min(Rng), 2) > Obj Then
65 Msg = "El valor objetivo es menor que el menor de los valores listados."
66 Exit Sub
67 End If
68 'Verifico suma total
69 If Round(WorksheetFunction.Sum(Rng), 2) = Obj Then
70 Rng.Offset(, 1) = 1: Q = Rng.Count: Exit Sub
71 End If
72 Vec1 = Evaluate("TRANSPOSE(SMALL(100*" & _
73 Rng.Address & " + (ROW(" & _
74 Rng.Address & ")/1000), ROW(1:" & _
75 Rng.Count & ")))")
76 x = 1 + UBound(Vec1)
77 ReDim Fil(1 To x)
78 ReDim Vec2(1 To x)
79 Vec2(1) = 0
80 For k = 2 To x
81 objParcial = Vec1(k - 1)
82 Vec2(k) = Int(objParcial) / 100
83 Fil(k) = (1000) * objParcial Mod 1000
84 Next k
85 Q = 1
86 '---
87 S00:
88 '---
89 ReDim T(1 To Q): ReDim U(1 To Q)
90 j = 1: x = 1 + UBound(Vec2)
91 Vec1 = Vec2
92 '---
93 S01:
94 '---
95 Do
96 objParcial = Round(Obj - WorksheetFunction.Sum(U), 2)
97 ReDim Preserve Vec1(1 To x - 1)
98 x = WorksheetFunction.Match(objParcial, Vec1, 1)
99 If x = 1 Then Exit Do
100 If j = 1 Then
101 ReDim Preserve Vec1(1 To x)
102 If Round(WorksheetFunction.Sum(Vec1), 2) < Obj Then GoTo noCombinations
103 End If
104 T(j) = x: U(j) = Vec2(x)
105 If U(j) = objParcial Then GoTo TargetFound
106 objParcial = WorksheetFunction.Sum(U)
107 For k = 1 To Q - j
108 If x - k = 1 Then Exit For
109 objParcial = objParcial + Vec2(x - k)
110 Next k
111 objParcial = Round(objParcial, 2)
112 If objParcial < Obj Then
113 Do While j > 1
114 If T(j - 1) - T(j) > 1 Then Exit Do
115 j = j - 1
116 Loop
117 Exit Do
118 End If
119 j = j + 1
120 If j > Q Then
121 j = j - 1: Exit Do
122 End If
123 Loop
124 '---------------------------
125 j = j - 1
126 '---
127 S02:
128 '---
129 If j = 0 Then GoTo OtroQ
130 T(j) = T(j) - 1
131 If T(j) = 1 Then
132 j = j - 1: GoTo S02
133 End If
134 U(j) = Vec2(T(j))
135 x = T(j)
136 Vec1 = Vec2
137 ReDim Preserve T(1 To j)
138 ReDim Preserve U(1 To j)
139 ReDim Preserve T(1 To Q)
140 ReDim Preserve U(1 To Q)
141 j = 1 + j: GoTo S01
142 '-----
143 OtroQ:
144 '-----
145 Q = 1 + Q
146 If Q < Rng.Count Then GoTo S00
147 '------
148 noCombinations:
149 '------
150 Msg = "No se encontró combinación."
151 GoTo Fin
152 '----------
153 TargetFound:
154 '----------
155 For j = 1 To Q
156 Cells(Fil(T(j)), "d") = 1
157 Next j
158 Rng.Offset(, -2).Resize(, 4).Sort [d3], xlAscending, Header:=xlNo
159 Fin:
160 Erase Vec1, T, U, Vec2, Fil
161 End Sub





Estos son los datos que estiy usando para la busqueda

Number Amount Offset Amount
A 68312.00 14100.00
K 31535.00 31535.00
M 63769.00 31535.00
R 31535.00 31535.00
T 39032.00 31535.00
U 39032.00 59201.00
V 50720.00 88826.00
Z 63769.00 230000.00
A10 29715.00 470000.00
A14 61925.00 1973387.00
A15 61925.00 2960895.00
A19 39032.00
A23 62469.00
A24 63257.00
A27 29715.00
A29 29715.00
A31 13999.00
A32 63769.00
A36 63769.00
A38 24780.00
B 843988.00
C 410575.00
D 277202.00
E 551747.00
F 465371.00
G 992869.00
L 644170.00
N 118085.00
Q 396936.00
S 100000.00
W 111477.00
Y 185400.00
A1 182702.00
A2 610180.00
A5 118085.00
A7 826005.00
A8 274100.00
A11 991930.00
A12 578000.00
A13 115593.00
A18 935500.00
A20 209840.00
A21 462075.00
A22 466623.00
A26 865835.00
A28 454540.00
A30 936700.00
A33 121418.00
A34 640390.00
A37 557470.00
A39 276400.00
A40 268435.00
A41 129016.00
A44 515635.00
H 1160365.00
I 1251545.00
J 3092433.00
O 4769620.00
P 9136690.00
X 2420740.00
A3 4195270.00
A6 1717500.00
A9 2377532.00
A16 5858760.00
A17 1184300.00
A25 1886740.00
A35 4374050.00
A42 7099920.00
A43 2064123.00
A45 3081256.00
A4 16781.08

De esta forma no se puede verificar el error.
Sube el libro con la macro.

Saludos.
\\//_

Hola Antoni,

muchas gracias por la respuesta. Adjunto el ZIP con el archivo

• Macro-error-Offset.zip(26,8 KB)

El problema en esta línea de la macro:


Es que primero realiza la multiplicación y después el Mod y causo desbordamiento.
La solución es forzar que realice primero el Mod y después la multiplicación.


Una vez superado este error da otro en el siguiente FOR:


Los valores del array Fil deberían ser números enteros mayores de 0 que corresponde a una fila. Los primeros valores del array son estos:


Saludos.
\\//_

Hola Antoni, Muchas gracias por su ayuda.

Perdon en molestarle. Adjunto el ZIP con las correcciones y el nuevo error. Creo que no entendi muy bien el ultimo paso '----------
TargetFound:
'----------
For j = 1 To Q
Cells(Fil(T(j)), "d") = 1
Next j

por si puedes revisarla y darme una guia de los cambios por favor?

• Macro-error-Offset-Copy.zip(27,2 KB)

El problema es que no se que es lo que se pretende que haga la macro.
Lo que hace ya lo se, dar un error.
Hay varias cosas que no me gustan y una de ellas es el sangrado, para ver mejor el código tengo que arreglarlo.
La otra son los GOTO que solo deben estar para un ON ERROR GOTO xxx.
La falta de comentarios no ayuda a entender la macro.
Otra cosa rara que he visto es un doble ReDim de dos tabla T y U en las líneas de l 173 a la 176. ¿Que sentido tiene?

Este es el código con el sangrado correcto.



Para entender que falla en estas líneas debo entender que se pretende hacer:


¿Que valor debe tener Q y de donde viene?
¿Que valores debe tener la tabla T(), de donde vienen y que se pretende hacer?
¿Que valores debe tener la tabla Fil(), de donde vienen y que se pretende hacer?
Estos últimos debían de ser números positivos mayores de CERO y menores o igual al número de filas de la hoja para que no de error.

Saludos.
\\//_

Buenas tardes yo encontré también esa macro creada por ' By Cacho Rodríguez
4 '--------- que es muy útil como bien mencionan en el área contable

Lo que se pretende que haga la macro es que de un rango de valores, muestre cuales de esos valores, suman un valor (objetivo), la macro corre bien con pocos valores, pero si le ponemos mas, entonces empieza el error de desbordamiento.

Ojala que con esto nos pueda ayudar a resolver el problema que arroja, ya que es una macro muy buena y con gran utilidad

Muchas gracias y saludos!