Hi Grace,

You need to ensure you follow the rules here, so let them know you have the thread on the other forum:

https://superuser.com/question…=1#comment2546142_1656880

I will have another look at the code tomorrow, I ran it but it is not working on your sheet as it did on the example I put together from the pictures you posted. Not sure why.

Anyone else interested, this is the code that was working to automate solver:

```
Sub SolverMacro(Add1 As String, Jval As Long)
Dim ws1 As Worksheet: Set ws1 = Sheet1
Dim ws2 As Worksheet: Set ws2 = Sheet2
Dim MyStr As String, MyCol As Long
Dim c As Range
mycount = 1
Do While ws2.Range("H4") > 1 And mycount < 5
'Solver section
'--------------------
SolverReset
SolverOk SetCell:="$H$3", MaxMinVal:=3, ValueOf:=0, ByChange:=Add1, _
Engine:=2, EngineDesc:="Simplex LP"
SolverAdd CellRef:=Add1, Relation:=5, FormulaText:="binary"
SolverAdd CellRef:="$H$4", Relation:=3, FormulaText:="1"
SolverSolve userfinish:=True
SolverFinish KeepFinal:=1 ', ReportArray:=Array(1)
'--------------------
'Loop identifies all invoices found in this solve and copies to a string then deletes the row
MyStr = "Total to 0: "
For i = Range(Add1).Cells.Count + 1 To 2 Step -1
If ws2.Range("D" & i) = 0 Then
ws2.Range("D" & i) = 1
GoTo MyNxti
Else
MyStr = Trim(MyStr & " " & ws2.Range("B" & i) & ", ")
ws2.Range("A" & i).Resize(1, 5).Delete xlUp
End If
MyNxti:
Next i
' ---------------------------
MyCol = ws2.Cells(Jval, Columns.Count).End(xlToLeft).Column + 1 'identifies last used row.
If Trim(MyStr) = "Total to 0:" Then GoTo MyExitLoop
ws2.Cells(Jval, MyCol) = Trim(MyStr) 'pastes string containing invoices that have added to zero
Add1 = "D2:D" & ws2.Range("D2").CurrentRegion.Rows.Count + 1
mycount = mycount + 1
Loop
MyExitLoop:
Add1 = "D2:D" & ws2.Range("D2").CurrentRegion.Rows.Count + 1
MyStr = "Outstanding: "
For Each c In ws2.Range(Add1)
MyStr = MyStr & ws2.Range("B" & c.Row) & ", "
ws2.Range("A" & c.Row).Resize(1, 5).Clear
Next c
MyCol = ws2.Cells(Jval, Columns.Count).End(xlToLeft).Column + 1 'identifies last used row.
ws2.Cells(Jval, MyCol) = MyStr 'pastes string containing invoices that have not added to zero
MyStr = vbNullString
End Sub
Sub ExtractorSub()
mystart = Time
Application.ScreenUpdating = False
'Declare variables
'---------------------------------------
Dim ws1 As Worksheet: Set ws1 = Sheet1
Dim ws2 As Worksheet: Set ws2 = Sheet2
Dim MyUniqueArr, MyFullArr
Dim x As Long, y As Long, MyRW As Long, Add1 As String, Add2 As String
ws2.Range("G1") = "Target"
ws2.Range("H1") = 0
ws2.Range("G2") = "Sum"
ws2.Range("H2") = "=SUM(INDIRECT(""$E2:E""&COUNTA($E:$E)+1))"
ws2.Range("G3") = "Difference"
ws2.Range("H3") = "=SUM(INDIRECT(""$E2:E""&COUNTA($E:$E)+1))"
ws2.Range("G4") = "Sum of Bin"
ws2.Range("H4") = "=SUM(INDIRECT(""$D2:D""&COUNTA($D:$D)+1))"
'------------------------------------------
'use autofilter to create unique list on sheet 2
ws1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws2.Range("J1"), Unique:=True
'create array of full list and unique
MyUniqueArr = Application.Transpose(ws2.Range("J2:J" & ws2.Range("J" & Rows.Count).End(xlUp).Row))
MyFullArr = Application.Transpose(ws1.Range("A1:A" & ws1.Cells(Rows.Count, 1).End(xlUp).Row))
' place header on unique list
ws2.Range("Extract") = "ID Number"
'Loop through all unique ID numbers
For x = LBound(MyUniqueArr) To UBound(MyUniqueArr)
For y = LBound(MyFullArr) To UBound(MyFullArr)
If MyUniqueArr(x) = MyFullArr(y) Then
MyRW = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1
ws1.Range("A" & y).Resize(1, 3).Copy ws2.Range("A" & MyRW).Resize(1, 3)
ws2.Cells(MyRW, 4) = 1
ws2.Cells(MyRW, 5) = "=$C" & MyRW & "*" & "$D" & MyRW
End If
Next y
Add1 = "D2:D" & MyRW
Call SolverMacro(Add1, x + 1)
Next x
Application.ScreenUpdating = True
MsgBox "Code took: " & Time - mystart & " seconds to complete."
End Sub
```

Display More
As indicated in the post on the other forum, I have activated the solver addin and ticked the solver reference (this does not work otherwise).