msahmed
11-20-2017, 09:15 AM
Hi there,
I don't know how to say this, but I will try explaining you in detail. I have some cells containing different amounts of which a combination of them will be equal to a particular number (I will enter it in a specified cell). I want a code to get the cell address of that combination of cells. I have the below code which works fine if the entries are few. But usually, I get some 50-70 numbers of amounts and the code will be overloaded and all excel application will hang out. The code I'm using is as follows:
Option Explicit
Private Target As Double
Private EndRow As Integer
Private Limit As Integer
Private OutRow As Integer
Private CellCount As Integer
Private BlankCells As Integer
Private i As Integer
Private CellVal As String
Private Sub CommandButton1_Click()
Application.ScreenUpdating = True
Columns(3).Clear
Target = Range("B1").Value
EndRow = Range("A1").End(xlDown).Row
Limit = EndRow
OutRow = 1
Add1 1, 0, "", 0
Call Replace
Range("C1").Select
ActiveCell.Offset(65000, 0).End(xlUp).Select
Range("C1", ActiveCell).Select
CellCount = WorksheetFunction.CountIf(Selection, "*")
Selection.Copy
Range("K1").Select
ActiveCell.PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
i = 1
Range("K1").Select
Do Until i > CellCount
CellVal = ActiveCell.Text
ActiveCell.Value = "=" & CellVal
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop
Range("A1").Select
MsgBox "Perfect!!!!"
End Sub
Private Sub Add1(ByVal BegRow As Integer, ByVal SumSoFar As Double, _
ByVal OutSoFar As String, ByVal Num As Integer)
Dim ThisRow As Long
Dim OneA As String
Application.ScreenUpdating = True
If (BegRow <= EndRow) And (SumSoFar < Target) And (Num < Limit) Then
For ThisRow = BegRow To EndRow
OneA = Cells(ThisRow, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
OneA = Cells(ThisRow, 1).Address
If OutSoFar <> "" Then
OneA = " + " & OneA
End If
If (Round(SumSoFar + Cells(ThisRow, 1).Value, 2) = Target) And (Num > 0) Then
Cells(OutRow, 3).Value = OutSoFar & OneA
OutRow = OutRow + 1
Else
Add1 ThisRow + 1, Round(SumSoFar + Cells(ThisRow, 1).Value, 2), _
OutSoFar & OneA, Num + 1
End If
Next ThisRow
End If
End Sub
Public Sub Replace()
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("i1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace what:="a", Replacement:="E", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace what:="+", Replacement:="&", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Columns.AutoFit
Application.CutCopyMode = False
Range("A1").Select
End Sub
It would be great if you could help me resolve this issue. Is the code needs to be developed or is there any other excel function available with which we can do this quickly. I have also tried using the Solver Add-on, but even that didn't work
Thanks in Advance,
Best in,
Hussain
I don't know how to say this, but I will try explaining you in detail. I have some cells containing different amounts of which a combination of them will be equal to a particular number (I will enter it in a specified cell). I want a code to get the cell address of that combination of cells. I have the below code which works fine if the entries are few. But usually, I get some 50-70 numbers of amounts and the code will be overloaded and all excel application will hang out. The code I'm using is as follows:
Option Explicit
Private Target As Double
Private EndRow As Integer
Private Limit As Integer
Private OutRow As Integer
Private CellCount As Integer
Private BlankCells As Integer
Private i As Integer
Private CellVal As String
Private Sub CommandButton1_Click()
Application.ScreenUpdating = True
Columns(3).Clear
Target = Range("B1").Value
EndRow = Range("A1").End(xlDown).Row
Limit = EndRow
OutRow = 1
Add1 1, 0, "", 0
Call Replace
Range("C1").Select
ActiveCell.Offset(65000, 0).End(xlUp).Select
Range("C1", ActiveCell).Select
CellCount = WorksheetFunction.CountIf(Selection, "*")
Selection.Copy
Range("K1").Select
ActiveCell.PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
i = 1
Range("K1").Select
Do Until i > CellCount
CellVal = ActiveCell.Text
ActiveCell.Value = "=" & CellVal
ActiveCell.Offset(1, 0).Select
i = i + 1
Loop
Range("A1").Select
MsgBox "Perfect!!!!"
End Sub
Private Sub Add1(ByVal BegRow As Integer, ByVal SumSoFar As Double, _
ByVal OutSoFar As String, ByVal Num As Integer)
Dim ThisRow As Long
Dim OneA As String
Application.ScreenUpdating = True
If (BegRow <= EndRow) And (SumSoFar < Target) And (Num < Limit) Then
For ThisRow = BegRow To EndRow
OneA = Cells(ThisRow, 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
OneA = Cells(ThisRow, 1).Address
If OutSoFar <> "" Then
OneA = " + " & OneA
End If
If (Round(SumSoFar + Cells(ThisRow, 1).Value, 2) = Target) And (Num > 0) Then
Cells(OutRow, 3).Value = OutSoFar & OneA
OutRow = OutRow + 1
Else
Add1 ThisRow + 1, Round(SumSoFar + Cells(ThisRow, 1).Value, 2), _
OutSoFar & OneA, Num + 1
End If
Next ThisRow
End If
End Sub
Public Sub Replace()
Range("C1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("i1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Replace what:="a", Replacement:="E", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace what:="+", Replacement:="&", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Columns.AutoFit
Application.CutCopyMode = False
Range("A1").Select
End Sub
It would be great if you could help me resolve this issue. Is the code needs to be developed or is there any other excel function available with which we can do this quickly. I have also tried using the Solver Add-on, but even that didn't work
Thanks in Advance,
Best in,
Hussain