+ Reply to Thread
Results 1 to 2 of 2

Knapsack Problem looping through Range

Hybrid View

  1. #1
    Registered User
    Join Date
    07-27-2011
    Location
    hamburg, germany
    MS-Off Ver
    Excel 2003
    Posts
    1

    Question Knapsack Problem looping through Range

    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!

  2. #2
    Valued Forum Contributor mohd9876's Avatar
    Join Date
    05-04-2011
    Location
    Amman, Jordan
    MS-Off Ver
    Excel 2010
    Posts
    426

    Re: Knapsack Problem looping through Range

    I think the problem is in this:
    dblZielwert(iCount)
    because you are trying to access a non array variable as array; so you should declare it as array or use it as non array

+ Reply to Thread

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1