Bom dia a Todos,
Geralmente todos os meses sou confrontado com uma situação no qual perco imenso tempo e após pesquisa na net acho que encontrei a solução para esse problema, no entanto como não precebo nada de Macros e apesar de ter a solução para o problema (descobri na net), não sei como a utilizar em excel, nomeadamente onde inserir a procura de dados e onde obtenho o resultado.
Será que algém me pode dar uma ajuda???
Passo a transcrever o tipo de problema que normalmente enfrento:
"Um departamento de contas a receber de clientes recebe um cheque de um cliente por US $ 4,556.92. Ao olhar no sistema de contabilidade, existem 54 faturas não pagas, que variam de $ 77,74 a US $ 5,465.45. O pagamento deve ser por alguma combinação exata de facturas inteiras, mas não sabemos qual faturas estão sendo pagos. A lista completa de notas fiscais para esse problema específico é mostrado abaixo."
895,39
83,6
280,71
1021,70
219,10
1587,52
507,8
628,89
222,52
192,65
194,58
764,18
680,23
244,22
89,40
862,12
1842,59
329,97
444,98
630,92
440,93
324,84
978,53
144,77
230,72
456,68
126,69
2487,85
515,11
911,45
983,98
329,17
673,47
409,17
228,31
796,76
116,14
858,97
718,32
346,35
542,12
589,18
789,77
185,58
538,64
441,43
925,39
698,27
5465,45
160,62
722,73
691,83
77,74
365,43
E aqui tenho a solução, no entanto preciso a mesma colocada num ficheiro excel, de forma a que possa colocar os valores que eu tenho para achar determinado resultado, de forma intuitiva para um leigo.
The solution:
First off, I never realized that I had posed a question which had 3,514 possible solutions.
We had a lively discussion with many possible directions. Ioannis popped in during the middle of the month and kept reporting success, but kept his winning macro a secret until the last minute. Simply for keeping us all baited so well, he caused a lot of anticipation for his macro, shown below.
I encourage anyone interested to read the entire 80+ posts here.
IOANNIS's winning macro:
Code:
--------------------------------------------------------------------------------
Dim INV() As Long
Dim CHECK As Long
Dim MAX_CHECK_INVS_No As Integer
Dim Sol As Long
Dim RESUME_No() As Integer
Dim RES_No As Integer
Dim RESUME_CALC As Integer
Dim MAX_RESUME_No As Integer
Dim AA As Long
Dim MAX_INVS As Integer
Dim MAX_DEPTH As Integer
Sub Challenge()
' SORTING
Columns("B:B").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
' CLEAR SOLUTION AREA
Columns("H:H").Select
Selection.ClearContents
Columns("M:P").Select
Selection.ClearContents
Cells(11, 4).Select
Selection.Activate
Cells(18, 6) = 0
Cells(7, 6) = 0
CHECK = Cells(2, 6) * 100
TOT_INV = Cells(1, 6)
ReDim INV(TOT_INV + 1)
MaxSum = 0
For i = 1 To TOT_INV
INV(i) = Cells(i, 2) * 100
MaxSum = MaxSum + INV(i)
Next
SUM_INV = 0
MAX_INVS = 0
For i = 1 To TOT_INV
SUM_INV = SUM_INV + INV(i)
If SUM_INV = CHECK Then MAX_INVS = i: Exit For
If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For
Next
Cells(3, 6) = MAX_INVS
MAX_CHECK_INVS_No = 1
i = 1
For i = TOT_INV To 2 Step -1
SUM_INV = INV(i)
If SUM_INV = CHECK Then GoTo Exit_for
For k = 1 To i
SUM_INV = SUM_INV + INV(k)
If SUM_INV <= CHECK Then
GoTo Exit_for
End If
Next
Next
Exit_for:
MAX_CHECK_INVS_No = i
INV(MAX_CHECK_INVS_No + 1) = MaxSum
Cells(4, 6) = MAX_CHECK_INVS_No
Sol = 0
AA = 0
Cells(14, 6) = Time
'Application.ScreenUpdating = False
Find_Sol 0, "", 0
Cells(10, 5) = Str(MAX_CHECK_INVS_No)
Cells(15, 6) = Time
Application.ScreenUpdating = True
End Sub
Sub Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Long)
For No_02% = No_01 + 1 To MAX_CHECK_INVS_No
NN_02$ = NN_01 + Str(No_02%)
SINVS_02& = SINVS_01 + INV(No_02%)
If SINVS_02& > CHECK Then Exit For
If SINVS_02& = CHECK Then
Sol = Sol + 1
If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
Cells(Sol, 8) = NN_02$
'Cells(10, 5) = NN_02$
Cells(15, 6) = Time
End If
If (SINVS_02& + INV(No_02% + 1)) > CHECK Then
If (INV(No_02%) = INV(No_02% + 1)) Then GoTo END_LOOP
MAX_No_01% = MAX_CHECK_INVS_No + 1
No_02% = No_02% + 1
START_LOOP:
CH_No% = MAX_No_01% - No_02%
If CH_No% > 1 Then
CH_No_m% = CH_No% / 2 + No_02%
If (SINVS_01 + INV(CH_No_m%)) > CHECK Then
MAX_No_01% = CH_No_m%
GoTo START_LOOP
End If
If (SINVS_01 + INV(CH_No_m%)) = CHECK Then
Sol = Sol + 1
If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
Cells(Sol, 8) = NN_01 + Str(CH_No_m%)
Exit For
End If
If (SINVS_01 + INV(CH_No_m%)) < CHECK Then
No_02% = CH_No_m%
GoTo START_LOOP
End If
Else
If CH_No% = 1 Then
No_02% = MAX_No_01% - 1
If (SINVS_01 + INV(No_02%)) = CHECK Then
Sol = Sol + 1
If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
Cells(Sol, 8) = NN_01 + Str(No_02%)
Exit For
End If
End If
Exit For
End If
End If
END_LOOP:
Find_Sol No_02%, NN_02$, SINVS_02&
Next_No_02:
Next No_02
End Sub
Sub RESUME_LAST_SOLUTION()
TOT_INV = Cells(1, 6)
ReDim RESUME_No(TOT_INV)
LAST_SOLUTION_No = Cells(5, 6)
If LAST_SOLUTION_No = 0 Then Exit Sub
LAST_SOLUTION = Cells(LAST_SOLUTION_No, 8)
Range("D:D").Select
Selection.ClearContents
If LAST_SOLUTION <> "" Then
LAST_SOLUTION = Trim(LAST_SOLUTION) + " "
SOL_LEN = Len(LAST_SOLUTION)
START_LEN = 1
AA = 1
For i = START_LEN To SOL_LEN
No = InStr(i, LAST_SOLUTION, " ")
Cells(AA, 4) = Mid(LAST_SOLUTION, i, No - i)
RESUME_No(AA) = Cells(AA, 4)
i = No
AA = AA + 1
Next
End If
End Sub
Sub COPY_SOLUTIONS()
AC_NAME = ActiveSheet.Name
N = 0
SOL_NAME = Cells(2, 6)
Do
N = N + 1
SOL_NAME_01 = Trim(Str(SOL_NAME)) + "_" + Trim(Str(N))
Loop Until Exist_SHEET(SOL_NAME_01) = 0
Cells(7, 6) = N
Create_SOLUTIONS_PAGE (SOL_NAME_01)
Sheets(AC_NAME).Select
Range("H1:I65536").Select
Selection.Copy
Sheets(SOL_NAME_01).Select
Range("B1").Select
ActiveSheet.Paste
Columns("B:C").AutoFit
Range("B1").Select
Sheets(AC_NAME).Select
Range("H1:I65536").Select
Selection.ClearContents
Range("E10").Activate
End Sub
Function Exist_SHEET(SH_NAME)
Exist_SHEET = 0
For Each SH In Sheets
If SH.Name = SH_NAME Then Exist_SHEET = 1: Exit For
Next SH
End Function
Sub Create_SOLUTIONS_PAGE(SH_NAME)
If Exist_SHEET(SH_NAME) Then
Else
Set NewSheet = Worksheets.Add
NewSheet.Name = SH_NAME
End If
End Sub
Sub RESUME_Challenge()
If Cells(5, 6) = 0 Then Exit Sub
' SORTING
Columns("B:B").Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
RESUME_LAST_SOLUTION
RESUME_CALC = 1
Cells(11, 4).Select
Selection.Activate
MAX_RESUME_No = Cells(8, 6)
CHECK = Cells(2, 6) * 100
TOT_INV = Cells(1, 6)
ReDim INV(TOT_INV + 1)
MaxSum = 0
For i = 1 To TOT_INV
INV(i) = Cells(i, 2) * 100
MaxSum = MaxSum + INV(i)
Next
SUM_INV = 0
MAX_INVS = 0
For i = 1 To TOT_INV
SUM_INV = SUM_INV + INV(i)
If SUM_INV = CHECK Then MAX_INVS = i: Exit For
If SUM_INV > CHECK Then MAX_INVS = i - 1: Exit For
Next
Cells(3, 6) = MAX_INVS
MAX_CHECK_INVS_No = 1
For i = TOT_INV To 2 Step -1
SUM_INV = INV(i)
If SUM_INV = CHECK Then GoTo Exit_for
For k = 1 To i
SUM_INV = SUM_INV + INV(k)
If SUM_INV <= CHECK Then
GoTo Exit_for
End If
Next
Next_i:
Next
Exit_for:
MAX_CHECK_INVS_No = i
INV(MAX_CHECK_INVS_No + 1) = MaxSum
Cells(4, 6) = MAX_CHECK_INVS_No
CHECK = MaxSum * 2
RES_No = 0
Sol = Cells(5, 6)
Cells(18, 6).Value = Cells(19, 6).Value
Cells(14, 6) = Time
No_01% = RESUME_No(1)
'Application.ScreenUpdating = False
RESUME_Find_Sol No_01%, "", 0
Cells(10, 5) = Str(MAX_CHECK_INVS_No)
Cells(15, 6) = Time
Application.ScreenUpdating = True
End Sub
Sub RESUME_Find_Sol(No_01 As Integer, NN_01 As String, SINVS_01 As Long)
For No_02% = No_01 + 1 To MAX_CHECK_INVS_No
If RESUME_CALC = 1 Then
RES_No = RES_No + 1
If RES_No > MAX_RESUME_No Then
RESUME_CALC = 2
CHECK = Cells(2, 6) * 100
No_02% = No_02% - 1
Exit For
Else
No_02% = RESUME_No(RES_No)
End If
End If
NN_02$ = NN_01 + Str(No_02%)
SINVS_02& = SINVS_01 + INV(No_02%)
If SINVS_02& > CHECK Then Exit For
If SINVS_02& = CHECK Then
Sol = Sol + 1
If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
Cells(Sol, 8) = NN_02$
'Cells(10, 5) = NN_02$
Cells(15, 6) = Time
End If
If (SINVS_02& + INV(No_02% + 1)) > CHECK Then
If (INV(No_02%) = INV(No_02% + 1)) Then GoTo END_LOOP
MAX_No_01% = MAX_CHECK_INVS_No + 1
No_02% = No_02% + 1
START_LOOP:
CH_No% = MAX_No_01% - No_02%
If CH_No% > 1 Then
CH_No_m% = CH_No% / 2 + No_02%
If (SINVS_01 + INV(CH_No_m%)) > CHECK Then
MAX_No_01% = CH_No_m%
GoTo START_LOOP
End If
If (SINVS_01 + INV(CH_No_m%)) = CHECK Then
Sol = Sol + 1
If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
Cells(Sol, 8) = NN_01 + Str(CH_No_m%)
Exit For
End If
If (SINVS_01 + INV(CH_No_m%)) < CHECK Then
No_02% = CH_No_m%
GoTo START_LOOP
End If
Else
If CH_No% = 1 Then
No_02% = MAX_No_01% - 1
If (SINVS_01 + INV(No_02%)) = CHECK Then
Sol = Sol + 1
If Sol > 65536 Then Sol = 1: COPY_SOLUTIONS
Cells(Sol, 8) = NN_01 + Str(No_02%)
Exit For
End If
End If
Exit For
End If
End If
END_LOOP:
RESUME_Find_Sol No_02%, NN_02$, SINVS_02&
Next_No_02:
Next No_02
End Sub
--------------------------------------------------------------------------------
.. Module 2 ...
Code:
--------------------------------------------------------------------------------
Dim Comp_No()
Function Print_No(Combination As String, Base As Integer) As Variant
Application.ScreenUpdating = False
Dim COMP As Integer
Dim Max_COMP As Integer
Dim ss, dd, i, k As Integer
Dim Co_02, Co_01 As Integer
Max_COMP = Val(SEPARATE_COMP(Combination, 0))
ReDim Comp_No(Max_COMP)
Dim Comp_SER(10, 2)
For COMP = 1 To Max_COMP
Comp_No(COMP) = Val(SEPARATE_COMP(Combination, COMP))
Next
ss = 0: dd = 0
Select Case Max_COMP
Case 1
Print_No = CDec(1)
For COMP = 1 To Comp_No(1) - 1
Print_No = CDec(Print_No + Count_Combinations(COMP, Base))
Next
Case Base: Print_No = CDec(Max_COMP)
Case Else
Co_01 = Comp_No(1)
For i = 2 To Max_COMP
Co_02 = Comp_No(i)
If Co_02 - Co_01 = 1 Then
Co_01 = Co_02
dd = dd + 1
Else
ss = ss + 1
Comp_SER(ss, 1) = Co_01
Comp_SER(ss, 2) = Co_02
Co_01 = Co_02
End If
Next
If ss = 0 Then
Print_No = CDec(Max_COMP)
For COMP = 1 To Comp_No(1) - 1
Print_No = CDec(Print_No + Count_Combinations(COMP, Base))
Next
Else
Print_No = CDec(Print_No + Max_COMP)
For i = 1 To ss
For k = Comp_SER(i, 1) + 1 To Comp_SER(i, 2) - 1
Print_No = CDec(Print_No + Count_Combinations(k, Base))
Next
Next
For COMP = 1 To Comp_No(1) - 1
Print_No = CDec(Print_No + Count_Combinations(COMP, Base))
Next
End If
End Select
Application.ScreenUpdating = True
End Function
Function Count_Combinations(No As Integer, Base As Integer) As Variant
Count_Combinations = CDec(2 ^ (Base - No))
End Function
Function SEPARATE_COMP(CELL_TEXT As String, No As Integer) As String
Application.ScreenUpdating = False
If CELL_TEXT = "" Then SEPARATE_COMP = "": Exit Function
' COUNT WORDS
CELL_TEXT = Trim(CELL_TEXT) + " "
TEXT_LEN% = Len(CELL_TEXT)
START_LEN% = 1
COUNTER_No% = 1
For i% = START_LEN% To TEXT_LEN%
FOUNT_POSITION_No% = InStr(i%, CELL_TEXT, " ")
WORD_FOUND = Mid(CELL_TEXT, i%, FOUNT_POSITION_No% - i%)
i% = FOUNT_POSITION_No%
If Trim(WORD_FOUND) <> "" Then
COUNTER_No% = COUNTER_No% + 1
End If
Next
MAX_WORDS% = COUNTER_No% - 1
If No = 0 Then
SEPARATE_COMP = MAX_WORDS%
Application.ScreenUpdating = True
Exit Function
End If
' PUT WORDS IN ARRAY
ReDim WORDS_FOUND(MAX_WORDS%)
START_LEN% = 1
COUNTER_No% = 1
For i% = START_LEN% To TEXT_LEN%
FOUNT_POSITION_No% = InStr(i%, CELL_TEXT, " ")
WORD_FOUND = Mid(CELL_TEXT, i%, FOUNT_POSITION_No% - i%)
i% = FOUNT_POSITION_No%
If Trim(WORD_FOUND) <> "" Then
WORDS_FOUND(COUNTER_No%) = WORD_FOUND
COUNTER_No% = COUNTER_No% + 1
End If
Next
If No > MAX_WORDS% Then No = MAX_WORDS%
SEPARATE_COMP = WORDS_FOUND(No)
Application.ScreenUpdating = True
End Function[/color]