No Remittance Advice - assistance with allocation

[HelpPlease1234]

Good Afternoon.
Working in a finance department, we quite often get issuesthat payments are received, but we have no idea what invoice numbers have beenpaid in that particular payment. This is because the client has not provided aremittance advice (list of invoices they have paid).
I am wondering if there is a way in EXCEL in which you canfind all possible combinations of a set of values. If there is, then this wouldhelp determine which invoices have been paid.
If anyone can provide any assistance on this it would begreatly appreciated.
Many Thanks

 

[bobsan42]

Here is a file set up to do just that: https://drive.google.com/file/d/13LZZefmUz_kaZlCy35nBj7NA_rPQC06M/view?usp=sharing
You have to allow macros, enter the invoice values in column A (from A2 down), enter Target sum in B2, then press the button.
in the columns to the left you will get the possible combinations (numbers are in order of appearance).
It was made some time ago in a hurry - it is not elegant or optimized, but works.
Do not give it large sets of data and have some patience

below is the code used in case you want to change it and adapt to your needs (this goes in a standard module, the routine to call is PowerSet)

Option Explicit
Option Compare Text




Public Sub CombineNumbers()
    Application.Calculation = xlCalculationManual
    Dim arrAllNumbers() As Single
    Dim arrCurrentNumbers() As Single
    Dim arrResults() As Single
    Dim RunningSum As Single
    Dim TargetValue As Single
    Dim i As Integer, j As Integer, k As Integer
    Dim rng As Range
    On Error GoTo errHandler
    TargetValue = Range("C2").Value
    Set rng = Range("A2").Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
    ReDim arrAllNumbers(1 To rng.Rows.Count, 1)
    ReDim arrCurrentNumbers(1 To UBound(arrAllNumbers, 1), 1)
    
    arrAllNumbers = rng
'    Range("B2").Resize(UBound(arrAllNumbers, 1)) = arrAllNumbers
    For i = 1 To UBound(arrAllNumbers, 1)
        If arrAllNumbers(i) = TargetValue Then
        
        End If
    Next i
    
exitPoint:
    Set rng = Nothing
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = "READY"
    Exit Sub
errHandler:
    MsgBox "Error occurred. " & vbCrLf & "Number: " & Err.Number & vbCrLf & Err.Description, _
            vbInformation + vbOKOnly
        Resume exitPoint
End Sub


Function ListPermut(num As Integer)
    'Permutations without repetition
    Dim c As Long, r As Long, p As Long
    Dim rng() As Long, temp As Long, i As Long
    Dim temp1 As Long, y() As Long, d As Long
    p = WorksheetFunction.Permut(num, num)
    ' Create array
    ReDim rng(1 To p, 1 To num)
    'Create first row in array (1, 2, 3, ...)
    For c = 1 To num
      rng(1, c) = c
    Next c
    For r = 2 To p
    ' 1. Find the first smaller number rng(r-1, c-1)<rng(r-1,c)
      For c = num To 1 Step -1
        If rng(r - 1, c - 1) < rng(r - 1, c) Then
          temp = c - 1
          Exit For
        End If
      Next c
    ' Copy values from previous row
      For c = num To 1 Step -1
        rng(r, c) = rng(r - 1, c)
      Next c
    ' 2. Find a larger number than rng(r-1, temp)as far to the right as possible
      For c = num To 1 Step -1
          If rng(r - 1, c) > rng(r - 1, temp) Then
              temp1 = rng(r - 1, temp)
              rng(r, temp) = rng(r - 1, c)
              rng(r, c) = temp1
              ReDim y(num - temp)
              i = 0
              For d = temp + 1 To num
                y(i) = rng(r, d)
                i = i + 1
              Next d
              i = 0
              For d = num To temp + 1 Step -1
                rng(r, d) = y(i)
                i = i + 1
              Next d
              Exit For
          End If
      Next c
    Next r
    ListPermut = rng
End Function






' PGC Oct 2007
' Calculates a Power Set
' Set in A1, down. Result in C1, down and accross. Clears C:Z.
Public Sub PowerSet()
    Application.Calculation = xlCalculationManual
    Dim vElements As Variant, vresult As Variant
    Dim lRow As Long, i As Long
    Dim vTarget As Single
    vTarget = Range("B2").Value
     
    vElements = Application.Transpose(Range("A2", Range("A2").End(xlDown)))
    Columns("D:ZZ").ClearContents
    
    lRow = 1
    For i = 1 To UBound(vElements)
        ReDim vresult(1 To i)
        Application.StatusBar = "Calculating combinations of " & i & " number(s)"
        Call CombinationsNP(vElements, i, vresult, lRow, 1, 1, vTarget)
    Next i
    Debug.Print "done"
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = "READY"


End Sub
 
Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lRow As Long, iElement As Integer, iIndex As Integer, Optional targetSum As Single = 0)
    Dim i As Long
    Dim jRow As Long
    Dim kCol As Long
    Dim runSum As Single
    Dim vResult2() As Variant
     
    For i = iElement To UBound(vElements)
        vresult(iIndex) = vElements(i)
        If iIndex = p Then
            runSum = 0
            For jRow = LBound(vresult) To UBound(vresult)
                runSum = runSum + vresult(jRow)
'                Debug.Print vresult(jRow),
            Next jRow
'            Debug.Print runSum
            
            If runSum = targetSum Then
                lRow = lRow + 1
                Range("B4").Offset(, lRow).Resize(p) = Application.Transpose(vresult)
            End If
        Else
            Call CombinationsNP(vElements, p, vresult, lRow, i + 1, iIndex + 1, targetSum)
        End If
    Next i
End Sub