Is there a function in Excel where you can select a column of figures, then
ask what figures in the column add up to a certain amount? Example - you
have a check for $24,674.82 and a long list of amounts. The check may be for
20 or 30 amounts totaled together in the column. Thanks!

You can use Solver or VBA


See:

http://www.tushar-mehta.com/excel/te...ues/index.html
--
Gary''s Student - gsnu200751


"Linda" wrote:

Is there a function in Excel where you can select a column of figures, then
ask what figures in the column add up to a certain amount? Example - you
have a check for $24,674.82 and a long list of amounts. The check may be for
20 or 30 amounts totaled together in the column. Thanks!

Here's one I picked off from one of these groups for my Personal
Macros Workbook recently. It works pretty well.

After you paste this into a standard module, ensure that Tools-
References has these two checked:

'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0

Hope this helps.



Sub FindSums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove


' Const tol As Double = 0.000001 'modify as needed
Dim c As Variant
Dim tol As Double, Temp As Variant


Dim j As Long, K As Long, N As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim V As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp


re.Global = True
re.IgnoreCase = True


On Error Resume Next


Set x = Application.InputBox( _
Prompt:="Enter range of values:", _
Title:="findsums", _
Default:="", _
Type:=8 _
)


If x Is Nothing Then
Err.Clear
Exit Sub
End If


y = Application.InputBox( _
Prompt:="Enter target value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(y) = vbBoolean Then
Exit Sub
Else
t = y
End If

Temp = Application.InputBox( _
Prompt:="Enter tolerance value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(Temp) = vbBoolean Then
tol = 0.01
Else
tol = Temp
End If


On Error GoTo 0


Set dco = dc1
Set dcn = dc2


Call recsoln


For Each y In x.Value2
If VarType(y) = vbDouble Then
If Abs(t - y) < tol Then
recsoln "+" & Format(y)


ElseIf dco.Exists(y) Then
dco(y) = dco(y) + 1


ElseIf y < t - tol Then
dco.Add Key:=y, Item:=1


c = CDec(c + 1)
If (c Mod 100 = 0) Then
Application.StatusBar = "[1] " & Format(c)
End If


End If


End If
Next y


N = dco.Count


ReDim V(1 To N, 1 To 3)


For K = 1 To N
V(K, 1) = dco.Keys(K - 1)
V(K, 2) = dco.Items(K - 1)
Next K


qsortd V, 1, N


For K = N To 1 Step -1
V(K, 3) = V(K, 1) * V(K, 2) + V(IIf(K = N, N, K + 1), 3)
If V(K, 3) t Then dcn.Add Key:="+" & Format(V(K, 1)), Item:=V(K,
1)
Next K


On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


For K = 2 To N
dco.RemoveAll
swapo dco, dcn


For Each y In dco.Keys
p = False


For j = 1 To N
If V(j, 3) < t - dco(y) - tol Then Exit For


x = V(j, 1)
s = "+" & Format(x)
If Right(y, Len(s)) = s Then p = True


If p Then
re.Pattern = "\" & s & "(?=(\+|$))"
If re.Execute(y).Count < V(j, 2) Then
u = dco(y) + x


If Abs(t - u) < tol Then
recsoln y & s


ElseIf u < t - tol Then
dcn.Add Key:=y & s, Item:=u


c = CDec(c + 1)
Application.StatusBar = "[" & Format(K) & "] " &
Format(c)


End If
End If
End If
Next j
Next y


If dcn.Count = 0 Then Exit For
Next K


If (recsoln() = 0) Then _
MsgBox Prompt:="all combinations exhausted", Title:="No Solution"


CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False


End Sub


Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "findsums solutions" 'modify to taste


Static r As Range
Dim ws As Worksheet


If s = "" And r Is Nothing Then
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)


If ws Is Nothing Then
Err.Clear
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set r = Worksheets.Add.Range("A1")
r.Parent.Name = OUTPUTWSN
ws.Activate
Application.ScreenUpdating = False


Else
ws.Cells.Clear
Set r = ws.Range("A1")


End If


recsoln = 0


ElseIf s = "" Then
recsoln = r.Row - 1
Set r = Nothing


Else
r.Value = s
Set r = r.Offset(1, 0)
recsoln = r.Row - 1


End If


End Function


Private Sub qsortd(V As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161


Dim j As Long, pvt As Long


If (lft = rgt) Then Exit Sub


swap2 V, lft, lft + Int((rgt - lft + 1) * Rnd)


pvt = lft


For j = lft + 1 To rgt
If V(j, 1) V(lft, 1) Then
pvt = pvt + 1
swap2 V, pvt, j
End If
Next j


swap2 V, lft, pvt


qsortd V, lft, pvt - 1
qsortd V, pvt + 1, rgt
End Sub


Private Sub swap2(V As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161


Dim t As Variant, K As Long


For K = LBound(V, 2) To UBound(V, 2)
t = V(i, K)
V(i, K) = V(j, K)
V(j, K) = t
Next K
End Sub


Private Sub swapo(a As Object, b As Object)
Dim t As Object


Set t = a
Set a = b
Set b = t
End Sub










On Oct 24, 4:48 pm, Gary''s Student
wrote:
You can use Solver or VBA

See:

http://www.tushar-mehta.com/excel/te...ues/index.html
--
Gary''s Student - gsnu200751



"Linda" wrote:
Is there a function in Excel where you can select a column of figures, then
ask what figures in the column add up to a certain amount? Example - you
have a check for $24,674.82 and a long list of amounts. The check may be for
20 or 30 amounts totaled together in the column. Thanks!- Hide quoted text -

- Show quoted text -

This works well for me:
Sub FindSeries()

Dim StartRng As Range
Dim EndRng As Range
Dim Answer As Long
Dim TestTotal As Long

Answer = Range("B1") '<<< CHANGE

Set StartRng = Range("A1")
Set EndRng = StartRng
Do Until False
TestTotal = Application.Sum(Range(StartRng, EndRng))
If TestTotal = Answer Then
Range(StartRng, EndRng).Select
Exit Do
ElseIf TestTotal Answer Then
Set StartRng = StartRng(2, 1)
Set EndRng = StartRng
Else
Set EndRng = EndRng(2, 1)
If EndRng.Value = vbNullString Then
MsgBox "No series found"
Exit Do
End If
End If
Loop
End Sub

In ells A1:A41, create an array of numbers in such as this:
8
6
3
2
6
10
9
4
12
8
6
1
8
10
8
14
10
9
12
12
14
6
4
3
4
4
4
0
6
10
4
9
6
3
11
12
10
7
12
8
8

Put this in Cell B1:
90

Run the macro!!

This is VERY cool too:
http://www.microsoft.com/office/comm...=en-us&m=1&p=1

Good luck!
Ryan---


--
RyGuy


"ilia" wrote:

Here's one I picked off from one of these groups for my Personal
Macros Workbook recently. It works pretty well.

After you paste this into a standard module, ensure that Tools-
References has these two checked:

'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0

Hope this helps.



Sub FindSums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove


' Const tol As Double = 0.000001 'modify as needed
Dim c As Variant
Dim tol As Double, Temp As Variant


Dim j As Long, K As Long, N As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim V As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp


re.Global = True
re.IgnoreCase = True


On Error Resume Next


Set x = Application.InputBox( _
Prompt:="Enter range of values:", _
Title:="findsums", _
Default:="", _
Type:=8 _
)


If x Is Nothing Then
Err.Clear
Exit Sub
End If


y = Application.InputBox( _
Prompt:="Enter target value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(y) = vbBoolean Then
Exit Sub
Else
t = y
End If

Temp = Application.InputBox( _
Prompt:="Enter tolerance value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(Temp) = vbBoolean Then
tol = 0.01
Else
tol = Temp
End If


On Error GoTo 0


Set dco = dc1
Set dcn = dc2


Call recsoln


For Each y In x.Value2
If VarType(y) = vbDouble Then
If Abs(t - y) < tol Then
recsoln "+" & Format(y)


ElseIf dco.Exists(y) Then
dco(y) = dco(y) + 1


ElseIf y < t - tol Then
dco.Add Key:=y, Item:=1


c = CDec(c + 1)
If (c Mod 100 = 0) Then
Application.StatusBar = "[1] " & Format(c)
End If


End If


End If
Next y


N = dco.Count


ReDim V(1 To N, 1 To 3)


For K = 1 To N
V(K, 1) = dco.Keys(K - 1)
V(K, 2) = dco.Items(K - 1)
Next K


qsortd V, 1, N


For K = N To 1 Step -1
V(K, 3) = V(K, 1) * V(K, 2) + V(IIf(K = N, N, K + 1), 3)
If V(K, 3) t Then dcn.Add Key:="+" & Format(V(K, 1)), Item:=V(K,
1)
Next K


On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


For K = 2 To N
dco.RemoveAll
swapo dco, dcn


For Each y In dco.Keys
p = False


For j = 1 To N
If V(j, 3) < t - dco(y) - tol Then Exit For


x = V(j, 1)
s = "+" & Format(x)
If Right(y, Len(s)) = s Then p = True


If p Then
re.Pattern = "\" & s & "(?=(\+|$))"
If re.Execute(y).Count < V(j, 2) Then
u = dco(y) + x


If Abs(t - u) < tol Then
recsoln y & s


ElseIf u < t - tol Then
dcn.Add Key:=y & s, Item:=u


c = CDec(c + 1)
Application.StatusBar = "[" & Format(K) & "] " &
Format(c)


End If
End If
End If
Next j
Next y


If dcn.Count = 0 Then Exit For
Next K


If (recsoln() = 0) Then _
MsgBox Prompt:="all combinations exhausted", Title:="No Solution"


CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False


End Sub


Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "findsums solutions" 'modify to taste


Static r As Range
Dim ws As Worksheet


If s = "" And r Is Nothing Then
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)


If ws Is Nothing Then
Err.Clear
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set r = Worksheets.Add.Range("A1")
r.Parent.Name = OUTPUTWSN
ws.Activate
Application.ScreenUpdating = False


Else
ws.Cells.Clear
Set r = ws.Range("A1")


End If


recsoln = 0


ElseIf s = "" Then
recsoln = r.Row - 1
Set r = Nothing


Else
r.Value = s
Set r = r.Offset(1, 0)
recsoln = r.Row - 1


End If


End Function


Private Sub qsortd(V As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161


Dim j As Long, pvt As Long


If (lft = rgt) Then Exit Sub


swap2 V, lft, lft + Int((rgt - lft + 1) * Rnd)


pvt = lft


For j = lft + 1 To rgt
If V(j, 1) V(lft, 1) Then
pvt = pvt + 1
swap2 V, pvt, j
End If
Next j


swap2 V, lft, pvt


qsortd V, lft, pvt - 1
qsortd V, pvt + 1, rgt
End Sub


Private Sub swap2(V As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161


Dim t As Variant, K As Long

Thank You! This makes my life a whole lot easier! :-)
--
Linda


"Gary''s Student" wrote:

You can use Solver or VBA


See:

http://www.tushar-mehta.com/excel/te...ues/index.html
--
Gary''s Student - gsnu200751


"Linda" wrote:

Is there a function in Excel where you can select a column of figures, then
ask what figures in the column add up to a certain amount? Example - you
have a check for $24,674.82 and a long list of amounts. The check may be for
20 or 30 amounts totaled together in the column. Thanks!

--
Linda


"ilia" wrote:

Here's one I picked off from one of these groups for my Personal
Macros Workbook recently. It works pretty well.

After you paste this into a standard module, ensure that Tools-
References has these two checked:

'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0

Hope this helps.



Sub FindSums()
'This *REQUIRES* VBAProject references to
'Microsoft Scripting Runtime
'Microsoft VBScript Regular Expressions 1.0
'Written by Harlan Grove


' Const tol As Double = 0.000001 'modify as needed
Dim c As Variant
Dim tol As Double, Temp As Variant


Dim j As Long, K As Long, N As Long, p As Boolean
Dim s As String, t As Double, u As Double
Dim V As Variant, x As Variant, y As Variant
Dim dc1 As New Dictionary, dc2 As New Dictionary
Dim dcn As Dictionary, dco As Dictionary
Dim re As New RegExp


re.Global = True
re.IgnoreCase = True


On Error Resume Next


Set x = Application.InputBox( _
Prompt:="Enter range of values:", _
Title:="findsums", _
Default:="", _
Type:=8 _
)


If x Is Nothing Then
Err.Clear
Exit Sub
End If


y = Application.InputBox( _
Prompt:="Enter target value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(y) = vbBoolean Then
Exit Sub
Else
t = y
End If

Temp = Application.InputBox( _
Prompt:="Enter tolerance value:", _
Title:="findsums", _
Default:="", _
Type:=1 _
)

If VarType(Temp) = vbBoolean Then
tol = 0.01
Else
tol = Temp
End If


On Error GoTo 0


Set dco = dc1
Set dcn = dc2


Call recsoln


For Each y In x.Value2
If VarType(y) = vbDouble Then
If Abs(t - y) < tol Then
recsoln "+" & Format(y)


ElseIf dco.Exists(y) Then
dco(y) = dco(y) + 1


ElseIf y < t - tol Then
dco.Add Key:=y, Item:=1


c = CDec(c + 1)
If (c Mod 100 = 0) Then
Application.StatusBar = "[1] " & Format(c)
End If


End If


End If
Next y


N = dco.Count


ReDim V(1 To N, 1 To 3)


For K = 1 To N
V(K, 1) = dco.Keys(K - 1)
V(K, 2) = dco.Items(K - 1)
Next K


qsortd V, 1, N


For K = N To 1 Step -1
V(K, 3) = V(K, 1) * V(K, 2) + V(IIf(K = N, N, K + 1), 3)
If V(K, 3) t Then dcn.Add Key:="+" & Format(V(K, 1)), Item:=V(K,
1)
Next K


On Error GoTo CleanUp
Application.EnableEvents = False
Application.Calculation = xlCalculationManual


For K = 2 To N
dco.RemoveAll
swapo dco, dcn


For Each y In dco.Keys
p = False


For j = 1 To N
If V(j, 3) < t - dco(y) - tol Then Exit For


x = V(j, 1)
s = "+" & Format(x)
If Right(y, Len(s)) = s Then p = True


If p Then
re.Pattern = "\" & s & "(?=(\+|$))"
If re.Execute(y).Count < V(j, 2) Then
u = dco(y) + x


If Abs(t - u) < tol Then
recsoln y & s


ElseIf u < t - tol Then
dcn.Add Key:=y & s, Item:=u


c = CDec(c + 1)
Application.StatusBar = "[" & Format(K) & "] " &
Format(c)


End If
End If
End If
Next j
Next y


If dcn.Count = 0 Then Exit For
Next K


If (recsoln() = 0) Then _
MsgBox Prompt:="all combinations exhausted", Title:="No Solution"


CleanUp:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False


End Sub


Private Function recsoln(Optional s As String)
Const OUTPUTWSN As String = "findsums solutions" 'modify to taste


Static r As Range
Dim ws As Worksheet


If s = "" And r Is Nothing Then
On Error Resume Next
Set ws = ActiveWorkbook.Worksheets(OUTPUTWSN)


If ws Is Nothing Then
Err.Clear
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set r = Worksheets.Add.Range("A1")
r.Parent.Name = OUTPUTWSN
ws.Activate
Application.ScreenUpdating = False


Else
ws.Cells.Clear
Set r = ws.Range("A1")


End If


recsoln = 0


ElseIf s = "" Then
recsoln = r.Row - 1
Set r = Nothing


Else
r.Value = s
Set r = r.Offset(1, 0)
recsoln = r.Row - 1


End If


End Function


Private Sub qsortd(V As Variant, lft As Long, rgt As Long)
'ad hoc quicksort subroutine
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161


Dim j As Long, pvt As Long


If (lft = rgt) Then Exit Sub


swap2 V, lft, lft + Int((rgt - lft + 1) * Rnd)


pvt = lft


For j = lft + 1 To rgt
If V(j, 1) V(lft, 1) Then
pvt = pvt + 1
swap2 V, pvt, j
End If
Next j


swap2 V, lft, pvt


qsortd V, lft, pvt - 1
qsortd V, pvt + 1, rgt
End Sub


Private Sub swap2(V As Variant, i As Long, j As Long)
'modified version of the swap procedure from
'translated from Aho, Weinberger & Kernighan,
'"The Awk Programming Language", page 161


Dim t As Variant, K As Long