Iniciar sesiónCerrar
Correo:
Contraseña:
Entrar
Recordar sesión en este navegador
Iniciar sesiónIniciar sesiónCrear cuentaCrear cuenta
LWP » Foros » Excel » Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Excel - Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Volver
Nuevo Tema
<<>>
 
Vista:
sin imagen de perfil
Val: 4
Ha aumentado su posición en 4 puestos en Excel (en relación al último mes)
Gráfica de Excel

Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Publicado por Luis (5 intervenciones) el 10/05/2019 00:10:23
Hola,

muy buenas tardes. espero que se encuentren muy bien. Queria solictar su ayuda para que me ayuden a solucionar el error de la imagen adjunta del siguiente Macro. El mismo fue creado por Cacho Rodriguez pero si alguien me puede ayudar a corregir el error se los agradeceria mucho

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
Dim Rng As Range
Dim Obj#, Msg$, Q%

 
Sub ComponeSuma()
'-------------------

' By Cacho Rodríguez

'-------------------

Dim C As Range, Ini As Double
 
If Not IsNumeric([C3]) Or IsEmpty([C3]) Then Exit Sub
 
If WorksheetFunction.CountBlank(Range([C3], [c65536].End(xlUp))) > 0 Then
  MsgBox "El rango de datos contiene" & vbLf & "celdas en blanco."
  Exit Sub
End If
 
With Range([e2], [e1000].End(xlUp))
  If WorksheetFunction.Count(.Cells) = 0 Then
    MsgBox "Debe establecer -al menos- un objetivo."
    Exit Sub
  End If
  Application.ScreenUpdating = False
  .Sort [e2], xlAscending, Header:=xlYes
End With
 
Ini = Timer
Range("D:D,F:F").ClearContents
Hoja2.UsedRange.EntireColumn.Delete Shift:=xlToLeft
 
For Each C In Range([e2], [e2].End(xlDown))
Obj = Round(C, 2): Msg = "": ComponeSuma_op
  Select Case Msg = ""
    Case True: ToHoja2
    Case False: C.Offset(, 1) = Msg
  End Select
Next C
 
Set Rng = Nothing
With Hoja2
  Application.GoTo .[a1], True
  .[a1:a3] = WorksheetFunction.Transpose(Array("Tiempo de", "proceso", Timer - Ini))
  .[a3].NumberFormat = "0.000 ""seg"""
  .UsedRange.EntireColumn.AutoFit
End With
 
Application.ScreenUpdating = True
End Sub
 
Private Sub ToHoja2()
Dim j%, k%
 
j = 3: k = 2 + Q
 
With Hoja2.[da1].End(xlToLeft)
  [e2].Copy .Offset(, 4).Resize(2)
  .Offset(, 4).Resize(2) = WorksheetFunction.Transpose(Array("Objetivo", Obj))
 
  With .Offset(2, 2).Resize(1 + k - j, 3)
    Range("a" & j, "c" & k).Copy .Cells
    Range("a" & j, "d" & k).Delete xlShiftUp
  End With
End With
 
End Sub
 
Private Sub ComponeSuma_op()
Dim j%, x%, k%, objParcial#

Dim Vec1, T%(), U#(), Vec2, Fil

 
If IsEmpty([C3]) Then
  Msg = "Sin valores que analizar."
  Exit Sub
End If
 
Set Rng = Range([C3], [c2].End(xlDown))
 
'Verifico objetivo fuera de alcance

If Round(WorksheetFunction.Sum(Rng), 2) < Obj Then
  Msg = "El valor objetivo es mayor que la suma de los valores listados."
  Exit Sub
End If
 
'Verifico objetivo mínimo

If Round(WorksheetFunction.Min(Rng), 2) > Obj Then
  Msg = "El valor objetivo es menor que el menor de los valores listados."
  Exit Sub
End If
 
'Verifico suma total

If Round(WorksheetFunction.Sum(Rng), 2) = Obj Then
  Rng.Offset(, 1) = 1: Q = Rng.Count: Exit Sub
End If
 
Vec1 = Evaluate("TRANSPOSE(SMALL(100*" & _
  Rng.Address & " + (ROW(" & _
  Rng.Address & ")/1000), ROW(1:" & _
  Rng.Count & ")))")
 
x = 1 + UBound(Vec1)
ReDim Fil(1 To x)
ReDim Vec2(1 To x)
 
Vec2(1) = 0
For k = 2 To x
  objParcial = Vec1(k - 1)
  Vec2(k) = Int(objParcial) / 100
  Fil(k) = 1000 * objParcial Mod 1000
Next k
 
Q = 1
 
'---

S00:
'---

ReDim T(1 To Q): ReDim U(1 To Q)
j = 1: x = 1 + UBound(Vec2)
Vec1 = Vec2
 
'---

S01:
'---

Do
  objParcial = Round(Obj - WorksheetFunction.Sum(U), 2)
  ReDim Preserve Vec1(1 To x - 1)
  x = WorksheetFunction.Match(objParcial, Vec1, 1)
 
  If x = 1 Then Exit Do
 
  If j = 1 Then
    ReDim Preserve Vec1(1 To x)
    If Round(WorksheetFunction.Sum(Vec1), 2) < Obj Then GoTo noCombinations
  End If
 
  T(j) = x: U(j) = Vec2(x)
  If U(j) = objParcial Then GoTo TargetFound
 
  objParcial = WorksheetFunction.Sum(U)
  For k = 1 To Q - j
    If x - k = 1 Then Exit For
    objParcial = objParcial + Vec2(x - k)
  Next k
 
  objParcial = Round(objParcial, 2)
  If objParcial < Obj Then
    Do While j > 1
      If T(j - 1) - T(j) > 1 Then Exit Do
      j = j - 1
    Loop
    Exit Do
  End If
 
  j = j + 1
  If j > Q Then
    j = j - 1: Exit Do
  End If
Loop
'---------------------------

 
j = j - 1
 
'---

S02:
'---

If j = 0 Then GoTo OtroQ
T(j) = T(j) - 1
If T(j) = 1 Then
  j = j - 1: GoTo S02
End If
U(j) = Vec2(T(j))
x = T(j)
Vec1 = Vec2
ReDim Preserve T(1 To j)
ReDim Preserve U(1 To j)
ReDim Preserve T(1 To Q)
ReDim Preserve U(1 To Q)
 
j = 1 + j: GoTo S01
 
'-----

OtroQ:
'-----

Q = 1 + Q
If Q < Rng.Count Then GoTo S00
 
'------

noCombinations:
'------

Msg = "No se encontró combinación."
GoTo Fin
 
'----------

TargetFound:
'----------

For j = 1 To Q
  Cells(Fil(T(j)), "d") = 1
Next j
Rng.Offset(, -2).Resize(, 4).Sort [d3], xlAscending, Header:=xlNo
 
Fin:
Erase Vec1, T, U, Vec2, Fil
 
End Sub



Error-Macro-match-and-clear
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Publicado por Antoni Masana (2539 intervenciones) el 10/05/2019 11:50:35
El error se produce porque la variable C no contiene un número.

Posible solución:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
Dim Rng As Range
Dim Obj#, Msg$, Q%

 
Sub ComponeSuma()
    '-------------------

    ' By Cacho Rodríguez

    '-------------------

    Dim C As Range, Ini As Double
 
    If Not IsNumeric([C3]) Or IsEmpty([C3]) Then Exit Sub
 
    If WorksheetFunction.CountBlank(Range([C3], [c65536].End(xlUp))) > 0 Then
        MsgBox "El rango de datos contiene" & vbLf & "celdas en blanco."
        Exit Sub
    End If
 
    With Range([e2], [e1000].End(xlUp))
        If WorksheetFunction.Count(.Cells) = 0 Then
            MsgBox "Debe establecer -al menos- un objetivo."
            Exit Sub
        End If
        Application.ScreenUpdating = False
        .Sort [e2], xlAscending, Header:=xlYes
    End With
 
    Ini = Timer
    Range("D:D,F:F").ClearContents
    Hoja2.UsedRange.EntireColumn.Delete Shift:=xlToLeft
 
    For Each C In Range([e2], [e2].End(xlDown))
        If IsNumeric(C) Then
            Obj = Round(C, 2): Msg = "": ComponeSuma_op
            Select Case Msg = ""
                Case True: ToHoja2
                Case False: C.Offset(, 1) = Msg
            End Select
        End If
    Next C
 
    Set Rng = Nothing
    With Hoja2
        Application.GoTo .[a1], True
        .[a1:a3] = WorksheetFunction.Transpose(Array("Tiempo de", "proceso", Timer - Ini))
        .[a3].NumberFormat = "0.000 ""seg"""
        .UsedRange.EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub
 
Private Sub ToHoja2()
    Dim j%, k%
 
    j = 3: k = 2 + Q
    With Hoja2.[da1].End(xlToLeft)
        [e2].Copy .Offset(, 4).Resize(2)
        .Offset(, 4).Resize(2) = WorksheetFunction.Transpose(Array("Objetivo", Obj))
 
        With .Offset(2, 2).Resize(1 + k - j, 3)
            Range("a" & j, "c" & k).Copy .Cells
            Range("a" & j, "d" & k).Delete xlShiftUp
        End With
    End With
End Sub
 
Private Sub ComponeSuma_op()
    Dim j%, x%, k%, objParcial#

    Dim Vec1, T%(), U#(), Vec2, Fil

 
    If IsEmpty([C3]) Then
        Msg = "Sin valores que analizar."
        Exit Sub
    End If
 
    Set Rng = Range([C3], [c2].End(xlDown))
 
    'Verifico objetivo fuera de alcance

    If Round(WorksheetFunction.Sum(Rng), 2) < Obj Then
        Msg = "El valor objetivo es mayor que la suma de los valores listados."
        Exit Sub
    End If
 
    'Verifico objetivo mínimo

    If Round(WorksheetFunction.Min(Rng), 2) > Obj Then
        Msg = "El valor objetivo es menor que el menor de los valores listados."
        Exit Sub
    End If
 
    'Verifico suma total

    If Round(WorksheetFunction.Sum(Rng), 2) = Obj Then
        Rng.Offset(, 1) = 1: Q = Rng.Count: Exit Sub
    End If
 
    Vec1 = Evaluate("TRANSPOSE(SMALL(100*" & _
    Rng.Address & " + (ROW(" & _
    Rng.Address & ")/1000), ROW(1:" & _
    Rng.Count & ")))")
 
    x = 1 + UBound(Vec1)
    ReDim Fil(1 To x)
    ReDim Vec2(1 To x)
 
    Vec2(1) = 0
    For k = 2 To x
        objParcial = Vec1(k - 1)
        Vec2(k) = Int(objParcial) / 100
        Fil(k) = 1000 * objParcial Mod 1000
    Next k
 
    Q = 1
 
S00:
    ReDim T(1 To Q): ReDim U(1 To Q)
    j = 1: x = 1 + UBound(Vec2)
    Vec1 = Vec2
 
S01:
    Do
        objParcial = Round(Obj - WorksheetFunction.Sum(U), 2)
        ReDim Preserve Vec1(1 To x - 1)
        x = WorksheetFunction.Match(objParcial, Vec1, 1)
 
        If x = 1 Then Exit Do
 
        If j = 1 Then
            ReDim Preserve Vec1(1 To x)
            If Round(WorksheetFunction.Sum(Vec1), 2) < Obj Then GoTo noCombinations
        End If
 
        T(j) = x: U(j) = Vec2(x)
        If U(j) = objParcial Then GoTo TargetFound
 
        objParcial = WorksheetFunction.Sum(U)
        For k = 1 To Q - j
            If x - k = 1 Then Exit For
            objParcial = objParcial + Vec2(x - k)
        Next k
 
        objParcial = Round(objParcial, 2)
        If objParcial < Obj Then
            Do While j > 1
                If T(j - 1) - T(j) > 1 Then Exit Do
                j = j - 1
            Loop
            Exit Do
        End If
 
        j = j + 1
        If j > Q Then
            j = j - 1: Exit Do
        End If
    Loop
    j = j - 1
 
S02:
    If j = 0 Then GoTo OtroQ
    T(j) = T(j) - 1
    If T(j) = 1 Then
        j = j - 1: GoTo S02
    End If
    U(j) = Vec2(T(j))
    x = T(j)
    Vec1 = Vec2
    ReDim Preserve T(1 To j)
    ReDim Preserve U(1 To j)
    ReDim Preserve T(1 To Q)
    ReDim Preserve U(1 To Q)
    j = 1 + j: GoTo S01
 
OtroQ:
    Q = 1 + Q
    If Q < Rng.Count Then GoTo S00
 
noCombinations:
    Msg = "No se encontró combinación."
    GoTo Fin
 
TargetFound:
    For j = 1 To Q
        Cells(Fil(T(j)), "d") = 1
    Next j
    Rng.Offset(, -2).Resize(, 4).Sort [d3], xlAscending, Header:=xlNo
 
Fin:
    Erase Vec1, T, U, Vec2, Fil
End Sub

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar
sin imagen de perfil
Val: 4
Ha aumentado su posición en 4 puestos en Excel (en relación al último mes)
Gráfica de Excel

Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Publicado por Luis (5 intervenciones) el 10/05/2019 12:33:05
Hola Antoni,

Muy buenos días. Muchas gracias por su respuesta. Voy a corregir el dato en el archivo de excel donde esta la macro con la información que me brindó. Muy gentil por su colaboración.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Publicado por Jesus (1 intervención) el 26/04/2021 13:47:37
Hola. Mi error en la misma macro y del mismo autor, es el siguiente. Alguien me puede ayudar. gracias.

Está localizado en la fila 106

Fil(k) = 1000 * objParcial Mod 1000
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar
Imágen de perfil de Antoni Masana
Val: 4.908
Oro
Ha mantenido su posición en Excel (en relación al último mes)
Gráfica de Excel

Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Publicado por Antoni Masana (2539 intervenciones) el 26/04/2021 20:42:52
Estaría bien abrir un nuevo post poner la macro, el libro y explicar el problema.

Entre otras cosas porque no estoy muy seguro que realice las mismas cosas que Luís y seguro, pero estoy muy seguro que no tiene los mismos datos en el libro.

Saludos.
\\//_
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Error Macro Sub ComponeSuma() Creada por cacho Rodriguez

Publicado por mia (1 intervención) el 06/07/2021 19:05:48
te dieron de respuesta, o pudiste encontrar el error que está localizado en la fila 106?

Fil(k) = 1000 * objParcial Mod 1000
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar