Loop ohne Do - STIMMT NICHT!

Sub liste_mittel_aufteilen()
'Seitenränder mit berücksichtigen
Dim frage
frage = MsgBox("Los gehts!" & Chr(13) & Chr(13) & "Sollen die Seitenränder gleich mit verkleinert werden (dauert länger)", vbYesNo, "Discoverer-Auswertung 4.0 by KrickelD")
Dim frage2
'frage2 = MsgBox("Und soll die aktive Tabelle während des Ablaufes minimiert werden? (geht noch schneller)", vbYesNo, "Discoverer-Auswertung 4.0 by KrickelD")
frage2 = vbYes 'Nur für Test-Zwecke
If frage2 = vbYes Then
ActiveWindow.WindowState = xlMinimized
End If
'für die einzelnen Zeitberechnungen
Dim ergebnis As String, feld As Integer, anzahl As Integer, count As Integer
ergebnis = ""
feld = 0
anzahl = 0
count = 1
Dim zeit_on
Dim zeit_off
Dim zeit_diff
zeit_on = Time
Dim temp
'Vorformatierungen
Range("I5:K5").Select
Selection.Cut Destination:=Range("I6:K6")
Rows("1:5").Select
Range("A1").Activate
Selection.Delete Shift:=xlUp
Columns("L:L").Delete Shift:=xlUp
Range("A1").Select
'Ursprungstabelle wegsichern
Sheets("Budgetauswertung").Select
Sheets("Budgetauswertung").Copy After:=Sheets(1)
Sheets("Budgetauswertung (2)").Name = "Ursprungstabelle"
Sheets("Budgetauswertung").Select
Range("A1").Select
Columns("D:D").Delete Shift:=xlUp
Columns("G:G").Delete Shift:=xlUp
Columns("D:D").HorizontalAlignment = xlCenter
Range("A1").Select
'*** neue Zeiten
Do While Range("A" & count) <> ""
If Range("A" & count) <> Range("A" & count + 1) Then
anzahl = anzahl + 1
End If
count = count + 1
Loop
Dim lauf(35) As String
'_Texte_markieren_und_hervorheben___________________________________________
Dim h As Integer
h = 1
Columns("I:I").Select
Selection.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "  'Zahlen-Formatierung
Columns("G:H").Select
Selection.NumberFormat = "#,##0"
Do While Range("A" & h) <> ""
If Range("D" & h) = "Zwischensumme (Vorab)Dotierung" Then   'Markieren
Range("D" & h).HorizontalAlignment = xlLeft
Rows(h & ":" & h).Font.Bold = True
End If
If Range("C" & h) = "Summe UB" Then                         'Markieren
Range("D" & h).Value = "Summe UB"
Range("D" & h).HorizontalAlignment = xlLeft
Range("A" & h & ":I" & h).Select                        '>> Wieder bis M
With Selection.Interior
.ColorIndex = 35
.Pattern = xlSolid
End With
Rows(h & ":" & h).Font.Bold = True
End If
If Range("B" & h) = "Summe Fachbudget" Then                 'Markieren
Range("A" & h & ":I" & h).Select                        '>> Wieder bis M
With Selection.Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
Rows(h & ":" & h).Font.Bold = True
End If
h = h + 1
Loop
'_Daten_in_neue_Tabelle_kopieren___________________________________________
Dim i As String
Dim j As Integer
Dim run As Integer
run = 0
Dim szeit   'Start- und Endzeit für jeden Durchlauf
Dim ezeit
Do While Range("A2").Text <> ""
szeit = Time
i = Range("A2")     'z.B. gleich 10 (für Blatt-Name)
j = 2               'Startzelle
Do While Range("A" & j) = i
j = j + 1
Loop
Range("A2:M" & j - 1).Cut       ' >> Hier stand von A2 bis Lj = Falsch. Es muss M sein.
Sheets.Add
ActiveSheet.Paste
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A2").Select              'Inhalte ausschneiden und in neue Tab einfügen
Range("A1").FormulaR1C1 = "FB"
Range("B1").FormulaR1C1 = "UB"
Range("C1").FormulaR1C1 = "EA-Art"
Range("D1").FormulaR1C1 = "HHSt."
Range("E1").FormulaR1C1 = "Bezeichnung"
Range("F1").FormulaR1C1 = "VB"
Range("G1").FormulaR1C1 = "Soll 2004"
Range("H1").FormulaR1C1 = "Soll 2003"                                    '>> Dieser Eintrag fehlte komplett
Range("I1").FormulaR1C1 = "Erg. 2002"                                    '>> Alle Anderen sind eine Spalte nach rechts
Range("A1:M1").HorizontalAlignment = xlCenter   'Überschriften zentrieren
Range("A1:M1").VerticalAlignment = xlCenter
Range("A1:M1").Font.Bold = True
ActiveSheet.Name = i
'Spaltenbreiten festlegen
Columns("A:A").ColumnWidth = 3
Columns("B:B").ColumnWidth = 2.14
Columns("C:C").ColumnWidth = 11
Columns("D:D").ColumnWidth = 11.29 'zentriert
Columns("E:E").ColumnWidth = 34.29 'Breite veränderbar
Columns("F:F").ColumnWidth = 2.86
Columns("G:G").ColumnWidth = 12.71
Columns("H:H").ColumnWidth = 12.71
Columns("I:I").ColumnWidth = 15.43
Columns("E:E").Select
With Selection
.WrapText = True
.Orientation = 0
.ShrinkToFit = False    'Zeilenhöhe nochmal korrigieren
.MergeCells = False
End With
Cells.Select
Cells.EntireRow.AutoFit
Columns("A:A").EntireColumn.Hidden = True        'ausblenden
Columns("C:C").EntireColumn.Hidden = True
ActiveSheet.PageSetup.CenterHeader = "Budget " & i      'Kopfzeile
If frage = vbYes Then
ActiveSheet.PageSetup.LeftMargin = Application.InchesToPoints(0.393700787401575)    'Seitenränder auf 1 cm
ActiveSheet.PageSetup.RightMargin = Application.InchesToPoints(0.393700787401575)
ActiveSheet.PageSetup.TopMargin = Application.InchesToPoints(0.78740157480315)
ActiveSheet.PageSetup.BottomMargin = Application.InchesToPoints(0.78740157480315)
End If
'Gitternetzlinien einzeichnen lassen
Range("A1:I" & j - 1).Select
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
'*******Zahlen neu berechnen************************************************
Dim l
l = 1
Dim summe_ub_03_ein As Double
Dim summe_ub_02_ein As Double
Dim summe_ub_03_aus As Double
Dim summe_ub_02_aus As Double
Dim summe_fb_03 As Double
Dim summe_fb_02 As Double
Dim end_03 As Double
Dim end_02 As Double
' für das einfügen der Formeln
Dim ein_von As Double
Dim ein_bis As Double
Dim aus_von As Double
Dim aus_bis As Double
Dim nur_aus As Boolean 'nur Ausgaben
Dim nur_ein As Boolean 'nur Einnahmen
nur_aus = False
nur_ein = False
Dim einmal As Boolean
einmal = False
ein_von = l + 1 'Zähler L für die Zeile
ein_bis = 0
aus_von = l
aus_bis = 0
summe_ub_03_ein = 0
summe_ub_02_ein = 0
summe_ub_03_aus = 0
summe_ub_02_aus = 0
summe_fb_03 = 0
summe_fb_02 = 0
end_03 = 0
end_02 = 0
Columns("I:I").Select
Selection.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
Range("A1").Select
'nicht vorab dotiert
Do While Range("A" & l) <> ""
'fürs Eintragen der Formel in Summe UB
Dim zw1 As Double
Dim zw2 As Double
'fürs Erstellen der Formeln
If Range("C" & l) = "Einnahme" And Range("D" & l) <> "" And Range("D" & l) <> "Zwischensumme (Vorab)Dotierung" Then
ein_bis = ein_bis + 1
End If
If Range("C" & l) = "Ausgabe" And Range("D" & l) <> "" And Range("D" & l) <> "Zwischensumme (Vorab)Dotierung" Then
aus_bis = aus_bis + 1
End If
If Range("D" & l) = "Zwischensumme (Vorab)Dotierung" Then
If einmal = False And Range("C2").Value = "Ausgabe" Then    'nur wenn am anfang
aus_von = aus_von + 1                                   'keine einnahme steht
'aus_bis = aus_bis + 1
End If
If Range("C" & l) = "Einnahme" Then
ein_bis = ein_von + ein_bis - 1
Range("G" & l).Formula = "=SUM(G" & ein_von & ":G" & ein_bis & ")"
aus_von = l + 1
zw1 = l 'L für Zeile ZWS-Ein
'If Range("C" & l + 1) <> "Ausgabe" Then
'    Range("G" & l).Formula = "=G" & zw1
'End If
End If
If Range("C" & l) = "Ausgabe" Then
aus_bis = aus_von + aus_bis - 1
Range("G" & l).Formula = "=SUM(G" & aus_von & ":G" & aus_bis & ")"
ein_von = l + 2
zw2 = l 'L für Zeile ZWS-Aus
End If
ein_bis = 0
aus_bis = 0
End If
'Einnahmen hochzählen
If Range("C" & l) = "Einnahme" And Range("D" & l) = "Zwischensumme (Vorab)Dotierung" Then
summe_ub_03_ein = Range("H" & l).Value
summe_ub_02_ein = Range("I" & l).Value
End If
'Ausgaben hochzählen
If Range("C" & l) = "Ausgabe" And Range("D" & l) = "Zwischensumme (Vorab)Dotierung" Then
summe_ub_03_aus = Range("H" & l).Value
summe_ub_02_aus = Range("I" & l).Value
End If
If Range("C" & l) = "Summe UB" Then
summe_fb_03 = summe_ub_03_ein - summe_ub_03_aus
Range("H" & l).Value = summe_fb_03
end_03 = end_03 + summe_fb_03
summe_fb_02 = summe_ub_02_ein - summe_ub_02_aus
Range("I" & l).Value = summe_fb_02
end_02 = end_02 + summe_fb_02
If nur_ein = True Then
Range("G" & l).Formula = "=G" & zw1
Else: Range("G" & l).Formula = "=SUM(G" & zw1 & "-G" & zw2 & ")"
If nur_aus = True Then
Range("G" & l).Formula = "=G" & zw2
Else: Range("G" & l).Formula = "=SUM(G" & zw1 & "-G" & zw2 & ")"
If einmal = False And Range("C2").Value = "Ausgabe" Then    'nur wenn am anfang
Range("G" & l).Formula = "=G" & zw2                     'keine einnahme steht
einmal = True
End If
End If
nur_ein = False
nur_aus = False
If Range("C" & l + 1) = "Ausgabe" Then
aus_von = l + 1
nur_aus = True
End If
End If
If Range("B" & l) = "Summe Fachbudget" Then
Dim zwcount As Integer
Dim zwstr As String
zwstr = "=SUM(G"
zwcount = 1
Do While Range("B" & zwcount) <> ""
If Range("D" & zwcount) = "Summe UB" Then
zwstr = zwstr & CStr(zwcount & "+G")
End If
If Range("B" & zwcount) = "Summe Fachbudget" Then
zwstr = Left(zwstr, Len(zwstr) - 2) & ")"
End If
zwcount = zwcount + 1
Loop
Range("H" & l).Value = end_03
Range("I" & l).Value = end_02
Range("G" & l).Formula = CStr(zwstr)
End If
l = l + 1
Loop
Rows(j + 1 & ":" & j + 1).Select
Selection.Insert Shift:=xlDown
ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"      'Wiederholungszeile einfügen
Range("G2").Select
Columns("G:G").Select           '*** BLATTSCHUTZ
Selection.Locked = False
Selection.FormulaHidden = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Range("G2").Select
Sheets("Budgetauswertung").Select
Rows("2:" & j - 1).Delete Shift:=xlUp  'leere Zellen löschen
ezeit = Time
lauf(run) = CDate(ezeit - szeit)
ergebnis = ergebnis & i & " : " & CStr(lauf(run)) & Chr(13)
run = run + 1
Loop
Sheets("Budgetauswertung").Select       '(leere) Ursprungstabelle löschen
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("Summe Verwaltungshaushalt").Select  '(leere) Tabelle löschen
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Sheets("10").Select             'zur ersten Tabelle springen (immer 10)
Range("A2").Select
zeit_off = Time
zeit_diff = CDate(zeit_off - zeit_on)
If frage2 = vbYes Then
ActiveWindow.WindowState = xlMaximized
End If
'MsgBox ergebnis
temp = MsgBox(" Fertig" & Chr(13) & Chr(13) & "Die Auswertung ist abgeschlossen!" & Chr(13) & Chr(13) & "Gesamtdauer: " & CStr(zeit_diff) & Chr(13) & Chr(13) & "Benötigte Einzel-Zeiten (pro Budget) anzeigen?", vbYesNo, "Discoverer-Auswertung 4.0 by KrickelD")
If temp = vbYes Then
temp = MsgBox("Benötigte Arbeitszeit pro Tabellenblatt:" & Chr(13) & Left(ergebnis, (Len(ergebnis) / 2) - 5), vbOKOnly, "Discoverer-Auswertung 4.0 by KrickelD (1/2)")
temp = MsgBox(Right(ergebnis, (Len(ergebnis) / 2) + 5), vbOKOnly, "Discoverer-Auswertung 4.0 by KrickelD (2/2)")
End If
End Sub