anscheinend wird einem hier nicht geholfen...Schade...

Option Explicit

Type myWerkzeug_Struct
  Name           As String
  Anz            As Long
  PreisProStueck As Double
  Preis          As Double
End Type

Private Const cRANGE_VORGABEBETRAG = A1
Private Const cRANGE_RESTBETRAG = A2
Private Const cRANGE_ANZWERKZEUGE = B1
Private Const cRANGE_WERKZEUGNAME_ANFANG = C1
Private Const cOFFSET_WERKZEUGANZAHL = 1
Private Const cOFFSET_WERKZEUGPREIS = 2
Private Const cOFFSET_WERKZEUGPREISGESAMT = 3


Sub BerechnungWerkzeugEinkauf()
  
  Dim dVorgabeBetrag As Double, lAnzWerkzeuge As Long
  Dim dRestBetrag As Double
  Dim WLi() As myWerkzeug_Struct, WLiCnt As Long
  Dim ws As Worksheet
  
  Set ws = ActiveSheet
  
  If Not WerteEinlesen(ws, dVorgabeBetrag, lAnzWerkzeuge, _
                       WLi(), WLiCnt) Then GoTo AUFRAEUMEN
  
  
  Call EinkaufBerechnen(dVorgabeBetrag, lAnzWerkzeuge, WLi(), WLiCnt, dRestBetrag)
  
  Call WerteAusgeben(ws, dRestBetrag, WLi(), WLiCnt)

AUFRAEUMEN:
  Set ws = Nothing
End Sub
'*****************************************************************
Private Function WerteAusgeben(ws As Worksheet, _
                               dRestBetrag As Double, _
                              WLi() As myWerkzeug_Struct, WLiCnt As Long)
  Dim x As Long
                           
  ws.Range(cRANGE_RESTBETRAG).Value = dRestBetrag

  With ws.Range(cRANGE_WERKZEUGNAME_ANFANG)
    For x = 1 To WLiCnt
      .Offset(x - 1, cOFFSET_WERKZEUGANZAHL).Value = WLi(x).Anz
      .Offset(x - 1, cOFFSET_WERKZEUGPREISGESAMT).Value = WLi(x).Preis
    Next
  End With
End Function

'*****************************************************************
Private Function EinkaufBerechnen(dVorgabeBetrag As Double, lAnzWerkzeuge As Long, _
                                  WLi() As myWerkzeug_Struct, WLiCnt As Long, _
                                  dRestBetrag As Double)

  Dim dVorgabeProWerkzeug As Double, x As Long, bNixGetan As Boolean

 ->VorgabeBetrag pro Werkzeug auf Euro runden
  dVorgabeProWerkzeug = dVorgabeBetrag \ lAnzWerkzeuge
  
 ->Für alle Werkzeuge die Anzahl aus dem VorgabeBetrag pro Werkzeug berechnen
  dRestBetrag = dVorgabeBetrag
  For x = 1 To WLiCnt
    WLi(x).Anz = dVorgabeProWerkzeug \ WLi(x).PreisProStueck
    WLi(x).Preis = WLi(x).Anz * WLi(x).PreisProStueck
    dRestBetrag = dRestBetrag - WLi(x).Preis
  Next

 ->die Werkzeuge der Reihenfolge nach prüfen,
 ->ob für den Restbetrag 1 Werkzeug gekauft werden kann.
 ->wenn ja, dann eins kaufen
 ->
 ->Das ganze solange bis der Restbetrag unter dem Preis
 ->des billigsten Werkzeugs liegt
  Do
    bNixGetan = True
    For x = 1 To WLiCnt
      If WLi(x).PreisProStueck <= dRestBetrag Then
        WLi(x).Anz = WLi(x).Anz + 1
        WLi(x).Preis = WLi(x).Preis + WLi(x).PreisProStueck
        dRestBetrag = dRestBetrag - WLi(x).PreisProStueck
        bNixGetan = False
      End If
    Next
    If bNixGetan Then Exit Do
  Loop

End Function



'*****************************************************************
Private Function WerteEinlesen(ws As Worksheet, _
                                dVorgabeBetrag As Double, _
                                lAnzWerkzeuge As Long, _
                                WLi() As myWerkzeug_Struct, WLiCnt As Long _
                                ) As Boolean

  Dim sWName As String, dWPreis As Double, z As Long
  
 ->VorgabeBetrag einlesen
  On Error Resume Next
  dVorgabeBetrag = ws.Range(cRANGE_VORGABEBETRAG).Value
  If Err.Number <> 0 Then
    MsgBox _
      Fehler beim Einlesen VorgabeBetrag. & vbLf & _
      Blatt  & ws.Name &  Zelle:  & cRANGE_VORGABEBETRAG & vbLf & _
      Err.Description
    Err.Clear: On Error GoTo 0: GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  If dVorgabeBetrag < 1# Then
    MsgBox _
      VorgabeBetrag < 1 ? & vbLf & _
      Blatt  & ws.Name &  Zelle:  & cRANGE_VORGABEBETRAG
    GoTo AUFRAEUMEN
  End If
  
 ->Anzahl Werkzeuge einlesen
  On Error Resume Next
  lAnzWerkzeuge = ws.Range(cRANGE_ANZWERKZEUGE).Value
  If Err.Number <> 0 Then
    MsgBox _
      Fehler beim Einlesen Anzahl Werkzeuge. & vbLf & _
      Blatt  & ws.Name &  Zelle:  & cRANGE_ANZWERKZEUGE & vbLf & _
      Err.Description
    Err.Clear: On Error GoTo 0: GoTo AUFRAEUMEN
  End If
  On Error GoTo 0
  If lAnzWerkzeuge < 1 Then
    MsgBox _
      Anzahl Werkzeuge < 1 & vbLf & _
      Blatt  & ws.Name &  Zelle:  & cRANGE_ANZWERKZEUGE
    GoTo AUFRAEUMEN
  End If
  
 ->Werkzeugliste einlesen
  WLiCnt = 0: ReDim WLi(1 To lAnzWerkzeuge)
  For z = 1 To lAnzWerkzeuge
    sWName = ws.Range(cRANGE_WERKZEUGNAME_ANFANG).Offset(z - 1, 0).Value
    On Error Resume Next
    dWPreis = ws.Range(cRANGE_WERKZEUGNAME_ANFANG). _
                       Offset(z - 1, cOFFSET_WERKZEUGPREIS).Value
    If Err.Number <> 0 Then
      MsgBox _
        Fehler beim Einlesen Werkzeuge-Preis. & vbLf & _
        Blatt  & ws.Name &  Zelle:  & _
            ws.Range(cRANGE_WERKZEUGNAME_ANFANG). _
            Offset(z - 1, cOFFSET_WERKZEUGPREIS).Address(False, False) & vbLf & _
        Err.Description
      Err.Clear: On Error GoTo 0: GoTo AUFRAEUMEN
    End If
    On Error GoTo 0
    If dWPreis <= 0# Then
      MsgBox _
        Werkzeugpreis <= 0 ? & vbLf & _
        Blatt  & ws.Name &  Zelle:  & _
            ws.Range(cRANGE_WERKZEUGNAME_ANFANG). _
            Offset(z - 1, cOFFSET_WERKZEUGPREIS).Address(False, False)
      GoTo AUFRAEUMEN
    End If
    
   ->Wert ok -> in Liste eintragen
    WLiCnt = WLiCnt + 1
    WLi(WLiCnt).Name = sWName
    WLi(WLiCnt).PreisProStueck = dWPreis
  Next

  WerteEinlesen = True
AUFRAEUMEN:

End Function