Do Until Schleife
26.06.2015 12:48:11
Lukas
ich habe folgendes Problem:
Nach dem der Code insgesamt funktioniert, habe ich versucht das ganze als Schleife durchlaufen zu lassen.
Das Problem dabei ist, dass die Schleife nicht mehr verlassen wird, nachdem im Zwischenspeicher Range("B2") leer ist.
Nach Abbruch durch ESC stehen aber alle gewüncshten Werte im Feld.
Was kann ich tun ?
Danke für die Hilfe!
Gruß
Lukas
Sub Eingabe()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Typ As String
Dim suche As Range
Dim SapNr As String
Dim Menge As Integer
Dim Ende As Long
Dim Bereich As Range, zelle As Range
'Schleife einleiten
Set currentCell = Worksheets("Zwischenspeicher").Range("B2")
Do While Not IsEmpty(currentCell)
'Werte zuordnen
Sheets("Zwischenspeicher").Activate
Typ = Range("B2").Value 'Typ Variable zuweisen
Menge = Range("C2").Value 'Menge Variable zuweisen
SapNr = Range("A2").Value 'SapNr Variable zuweisen
'Abfrage auf Vorgabeliste, ob MAE5 freie Kapazität hat
Sheets("Vorgabeliste").Activate
'MAE5
If Range("C3").Value = 3000 Then
Korrekturwert = Range("C3").Value
Übertrag = Korrekturwert - 3000
'letzte benutzte Zelle im Puffer finden
With ActiveSheet
Ende = .Cells(Rows.Count, 23).End(xlUp).Row
End With
'Werte in Puffer eintragen
Cells(Ende + 1, 22).Value = SapNr
Cells(Ende + 1, 23).Value = Typ
Cells(Ende + 1, 24).Value = Übertrag
'Wert MAE5 korrigieren
With ActiveSheet
Ende = .Cells(Rows.Count, 3).End(xlUp).Row
End With
Korrektur = Cells(Ende, 3).Value - Übertrag
Cells(Ende, 3).Value = Korrektur
End If
End If
'Umstieg auf Puffer
Else
'In Vorgabeliste eintragen
Sheets("Vorgabeliste").Activate
'letzte benutzte Zelle in Spalte 2 finden
With ActiveSheet
Ende = .Cells(Rows.Count, 23).End(xlUp).Row
End With
'Werte eintragen
Cells(Ende + 1, 22).Value = SapNr
Cells(Ende + 1, 23).Value = Typ
Cells(Ende + 1, 24).Value = Menge
'Zwischenspeicher leeren für nächsten Wert
Sheets("Zwischenspeicher").Activate
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Sheets("Vorgabeliste").Activate
End If
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub