Hi all,
that`s my first post in this forum and its a little bit tricky. I hope u can help me out with this one
First off all I got a VBA Code to match a particular Sum with multiple summands from a given list of numbers. From the code so far I am able to type in a Sum and get the matches displayed.
Unfortunately I need to loop through a complete column of those "potential" Sums and paste the summands (Matches) one column next to it (or n columns for n summands).
I tried to change the range and add a "i" loop to it. But it seems that everytime I m doing it, mismatch Data pops up. So I wasnt able to set the Range to the whole column. For instance I tried .Range("B" & iCount) or Range("B:B") or Cells(iCount, 2) and so on
So my question here is whether I did the syntax wrong or could be problem with the arrays themselves?
Here is the Code related to setting up the range:
For iCount = 1 To 10
With Me
dblZielwert(iCount) = ActiveSheet.Range("B" & iCount)
Here is the whole code, sub + function:
Option Explicit
Private Sub cmbBerechnen_Click()
Dim dblZielwert As Double
Dim dblToleranz As Double
Dim adblBeträge() As Double
Dim varResult As Variant
Dim m As Long
Dim n As Long
Dim iCount As Integer
For iCount = 1 To 10
With Me
dblZielwert(iCount) = ActiveSheet.Range("B" & iCount)
ReDim adblBeträge(1 To 100)
For m = 2 To 101
If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
adblBeträge(m - 1) = .Cells(m, 1)
Else
ReDim Preserve adblBeträge(1 To m - 1)
Exit For
End If
Next
ReDim Preserve adblBeträge(1 To UBound(adblBeträge) - 1)
varResult = Kombinationen(adblBeträge, dblZielwert, dblToleranz)
Application.ScreenUpdating = False
.Range(.Cells(3, 4), .Cells(UBound(varResult) + 3, 4)) = _
varResult
Application.ScreenUpdating = True
End With
Next iCount
End Sub
Option Explicit
Sub testen()
Dim varErg As Variant
varErg = Kombinationen(Array(10, 11, 13, 12), 25, 0.5)
End Sub
Public Function Kombinationen( _
Elemente As Variant, _
Sollwert As Variant, _
Optional Toleranz As Double, _
Optional Bisher As Variant, _
Optional Pos As Long) As Variant
Dim i As Long
Dim k As Long
Dim dblVergleich As Double
Dim dblDummy As Double
Dim varDummy As Variant
Dim varResult As Variant
If Not IsMissing(Bisher) Then
'Summe bisherige Elemente
For Each varDummy In Bisher
dblVergleich = dblVergleich + varDummy
Next
Else
'Ausgangselemente nach Größe sortieren
For i = 1 To UBound(Elemente)
For k = i + 1 To UBound(Elemente)
If Elemente(k) < Elemente(i) Then
dblDummy = Elemente(i)
Elemente(i) = Elemente(k)
Elemente(k) = dblDummy
End If
Next
Next
Set Bisher = New Collection
End If
If Pos = 0 Then Pos = LBound(Elemente)
For i = Pos To UBound(Elemente)
' Aktuellen Wert hinzufügen
Bisher.Add Elemente(i)
dblVergleich = dblVergleich + Elemente(i)
If Abs(Sollwert - dblVergleich) < (0.001 + Toleranz) Then
'Sollwert ist erreicht
k = 0
ReDim varResult(0 To Bisher.Count - 1, 0)
For Each varDummy In Bisher
varResult(k, 0) = varDummy
k = k + 1
Next
Kombinationen = varResult
Exit For
ElseIf dblVergleich < (Sollwert + 0.001 + Toleranz) Then
' Es ist noch Platz für einen Betrag
' Rekursiv aufrufen, beginnen mit nächsthöherem Wert
varResult = Kombinationen( _
Elemente, Sollwert, Toleranz, Bisher, i + 1)
If IsArray(varResult) Then
Kombinationen = varResult
Exit For
Else
Bisher.Remove Bisher.Count
dblVergleich = dblVergleich - Elemente(i)
End If
Else
' Wert ist zu groß
Bisher.Remove Bisher.Count
Exit For
End If
Next ' Nächsthöhere Zahl probieren
End Function
Thanks for ur help, I really do appreciate it!
Bookmarks