Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Combinação de valor...
 
Notifications
Clear all

Combinação de valores = Determinado resultado

 
2024 - VBA & Macros
Post Recente por RuiC. 10 anos atrás
6 Posts
3 Usuários
0 Reactions
1,568 Visualizações
RSS
 RuiC.
(@ruic)
Posts: 26
Eminent Member
Topic starter
 

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]
 
Postado : 30/03/2015 4:26 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Vc quer que, dada uma qtd variada de valores, encontre-se quais que somados resultam num valor específico.
Sinceramente, eu acho arriscado de mais, pois a qtd de combinações que podem gerar o mesmo resultado final pode ser imensa *(como avisa o colega em inglês).

O ideal seria mudar seu processo, perguntar para o cliente como ele chegou a esse valor que está sendo pago, quais faturas estão inclusas... Pq, falando sério, ninguém paga algo sem saber o que está pagando. Quem está desembolsando, sabe o que está desembolsando e porque...

O código está imenso, eu *(moderador) inclui o tag code para ficar numa caixa apropriada.

Penso que vc nunca chegará a uma solução ideal.
Se eu te dou uma lista de valores de 10 faturas:
10 / 20 / 30 / 40 / 50 / 60 / 70 / 80 / 90 / 100

E eu digo que paguei 150
Quais as faturas que eu paguei ?
100 e 50 ?
10, 20, 30, 40 e 50 ?

Nem imagino como vc resolveria essas 3514 possibilidades ...

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 30/03/2015 6:54 am
 Edcronos
(@edcronos)
Posts: 1006
Noble Member
 

concordo com o fernando,
o certo seria mudar o modo de operação

ou criar uma fatura unica e total de onde vai sendo subtraindo oq o cliente pagar, e dar um comprovante de abatimento, "acho que esse seria o mais pratico"

ou separar as faturas por data e aceitar apenas pagamentos integrais dessas

ou tirar o montante de faturas que corresponda aproximadamente ao valor
e devolver o troco,
ou gerar credito até chegar a um valor de sobra para pagar uma fatura inteira
(no caso oq se queria fazer com o programa, mas seria sem se preocupar muito com valores totais )

bem cada um sabe como melhor administrar o seu negocio

Somente é impossíveis até que alguém faça
A logica está presa na irracionalidade humana, e morta nos que se consideram donos da verdade.

"ALGUM MODERADOR ME EXPULSE DO FÓRUM POR FAVOR"

 
Postado : 30/03/2015 7:28 am
 RuiC.
(@ruic)
Posts: 26
Eminent Member
Topic starter
 

Bom dia,

Obriago pelas respostas, a verdade é que para ofeito que eu pretendo nunca estarão em causa tantos valores, os numeros raramnete são tão fáceis de advinhar.
Passo a explicar o que se passa:
Os meus clientes, por norma ou por desorganização ou falta de tempo ao depositarem dinheiro no banco esquece-se de emitir os recibos ou quando o fazem as datas dos recibos não coincidem com as datas dos depósitos.
Vou dar um exemplo:

No dia 25/03/2015 o meu cliente efetuou no banco um depósito de 6.555,00.
à contabilidade chegaram os seguintes recibos:
Recibo 100 emitido ao bbb= 268,45
Recibo 103 emitido ao aaa= 1.350,31
Recibo 104 emitido ao rrrr= 868,40
Recibo 108 emitido ao iiii= 3.268,45
Recibo 111 emitido ao lllll= 4.268,45
Recibo 112 emitido ao www= 297,35
Recibo 117 emitido ao zzzz= 415,78
Recibo 118 emitido ao jjjj= 425.96
Recibo 122 emitido ao kkkk= 2.669,62
Recibo 123 emitido ao qqqq= 1.852,78
Recibo 131 emitido ao vvvvv= 378,45
Recibo 134 emitido ao ttttt= 28,45
Recibo 141 emitido ao mmmm= 2.039,10

Destes recibos estão certamente uma combinação que resulta no valor exato daquele depósito, podendo até acontecer que tal não aconteça.
Neste caso a combinação resulta na soma dos seguintes valores: (1.350,31 + 868,40 + 415,96 + 1.852,78 + 28,45 + 2.039,10) = 6.555,00

Pode parecer fácil para alguns a combinação, mas quando temos o tempo contado e estas situações se repetem não há paciência que ajude.

Se puderem ajudar agradecia.

Cumprimentos,
Rui

 
Postado : 30/03/2015 8:19 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

O problema (ou demanda) é recorrente nos vários fóruns, com titulos diferentes, mas com mesmo objetivo.

Há algum tempo, no forul Excel-br circulou a planiha --> Encontrar Parcelas(JLM....) que utiliza o Solver, que talvez o auxilie.

Em adiconal uma rotina Encontrar Parcelas.rar, obtida em --> http://www.mrexcel.com/forum/showthread.php?t=5754 e modificada por mim

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 30/03/2015 8:47 am
 RuiC.
(@ruic)
Posts: 26
Eminent Member
Topic starter
 

Obrigado amigo, era mesmo isto que eu procurava.
Grande abraço,
Rui

 
Postado : 30/03/2015 9:47 am
Forum Jump:
  Tópico Anterior
Próximo Tópico