Fortschrittsbalken in Makro implementieren???

Sub BAB_öffnen()
' BAB_öffnen Makro
Dateiname = Application.GetOpenFilename(filefilter:="Text Files(*.txt), *.txt", Title:="Dateiöffnen")
ChDir _
"C:\Dokumente und Einstellungen\XXX\Desktop"
Workbooks.OpenText Filename:=Dateiname, _
Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
1), Array(13, 1), Array(34, 1), Array(48, 1), Array(62, 1), Array(76, 1), Array(96, 9), _
Array(116, 9), Array(123, 9))
'Name_löschen
Dim lz As Long, i As Long, c As Integer
Dim ws As Worksheet
Dim lngE As Long
Dim rng As Range
lngE = IIf(IsEmpty(Range("A65536")), Range("A65536").End(xlUp).Row, 65536)
For Each rng In Range("A1:A" & lngE)
If Left(rng.Formula, 4) = "=---" Then rng.ClearContents
Next
'Inhalt_Zelle_Text_loeschen
On Error Resume Next
Columns(1).SpecialCells(xlCellTypeConstants, 2).ClearContents
'selektieren
Set ws = ActiveSheet
lz = Range("A65536").End(xlUp).Row
c = 0
Application.ScreenUpdating = False
Do
For i = 1 To lz
If Cells(i, 1) = 10000 Or i = lz Then
Rows("1:" & i).Cut
Sheets.Add After:=Sheets(Sheets.Count)
c = c + 1
ActiveSheet.Name = "Teil " & c
ActiveSheet.Paste
[A1].Select
ws.Select
Rows("1:" & i).Delete Shift:=xlUp
lz = Range("A65536").End(xlUp).Row
Exit For
End If
Next i
Loop While lz > 1
Application.ScreenUpdating = True
'loeschen_erstes_Tabellenblatt
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'KST
Dim wks As Worksheet
For Each wks In ActiveWorkbook.Worksheets
With wks
.[I4] = Right(Left(.[F2], 8), 4) 'macht das selbe wie deine Formel
.Name = .[I4]
End With
Next
'ShowDLG
frmDelSheet.Show
'****Anfang der Schleife****
Dim wz As Worksheet
For Each wz In Worksheets
wz.Select
Application.screeupdating = False
'loeschen_Firma
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(i, 2) = "* AWO-KV KÖLN GST.*" Then
Rows(i).Delete Shift:=xlUp
End If
Next
'loeschen_Striche
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Cells(i, 2) = "---------------------" Then
Rows(i).Delete Shift:=xlUp
End If
Next
'loeschen_ab_Zeile_fuenf
Dim z As Long, a As Long
a = Range("A65536").End(xlUp).Row
For z = a To 5 Step -1
If Not IsNumeric(Cells(z, 1).Value) Or Cells(z, 1).Value = "" Then
Cells(z, 1).EntireRow.Delete
End If
Next z
'Kita_format
Range("A1:F4").Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
End With
Range("A1").Select
ActiveCell.FormulaR1C1 = "KTO"
Rows("1:4").Select
Selection.Insert Shift:=xlDown
Range("A7").Select
'Umwandeln
For zeIndex = 5 To 500
For spIndex = 3 To 6
If Right(Worksheets(ActiveSheet.Name).Cells(zeIndex, spIndex), 1) = "-" Then
If Val(Worksheets(ActiveSheet.Name).Cells(zeIndex, spIndex)) <> -1 Then
Worksheets(ActiveSheet.Name).Cells(zeIndex, spIndex).Value = CDbl(CCur(Worksheets(ActiveSheet.Name).Cells(zeIndex, spIndex).Value))
End If
End If
Next spIndex
Next zeIndex
'Blattname_in_Zelle
[C3] = ActiveSheet.Name
'Formatieren_Währung
Range("C9:F200").Select
Range("C9:F200").Activate
Selection.NumberFormat = "#,##0.00 [$€-1]_ ;-#,##0.00 [$€-1] "
Range("G3").Select
'Zeilen_einfügen1
Dim lngZeile As Long
For lngZeile = Cells(65536, 1).End(xlUp).Row To 1 Step -1
If Cells(lngZeile, 1) = 1000 Or Cells(lngZeile, 1) = 2000 Or Cells(lngZeile, 1) = 3000 Or Cells(lngZeile, 1) = 4000 Or Cells(lngZeile, 1) = 5000 Or Cells(lngZeile, 1) = 6000 Or Cells(lngZeile, 1) = 7000 Or Cells(lngZeile, 1) = 8000 Or Cells(lngZeile, 1) = 9000 Or Cells(lngZeile, 1) = 10000 Then
With Rows(lngZeile + 1)
.Insert Shift:=xlShiftDown
End With
End If
Next
'Zeilen_einfügen2
For lngZeile = Cells(65536, 1).End(xlUp).Row To 1 Step -1
If Cells(lngZeile, 1) = 1000 Or Cells(lngZeile, 1) = 2000 Or Cells(lngZeile, 1) = 3000 Or Cells(lngZeile, 1) = 4000 Or Cells(lngZeile, 1) = 5000 Or Cells(lngZeile, 1) = 6000 Or Cells(lngZeile, 1) = 7000 Or Cells(lngZeile, 1) = 8000 Or Cells(lngZeile, 1) = 9000 Or Cells(lngZeile, 1) = 10000 Then
With Rows(lngZeile)
.Font.Bold = True
End With
End If
Next
'SpalteI_inhalt_löschen
Columns("I:I").Select
Selection.Delete Shift:=xlToLeft
'Schriftgröße
Columns("A:F").Select
With Selection.Font
.Name = "Arial"
.Size = 14
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("A1").Select
'Spaltenbreite
Range("A:F").EntireColumn.AutoFit
'Kita_format2
Range("A3").Select
ActiveCell.FormulaR1C1 = "BAB"
Range("B3").Select
ActiveCell.FormulaR1C1 = "Kostenstelle:"
Range("B3").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.Orientation = 0
End With
Range("C3").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.Orientation = 0
.IndentLevel = 0
End With
Range("A3:F3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDashDot
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Range("A8:F8").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Range("A3:F3").Select
Selection.Font.Bold = True
Range("C6").Select
'Wiederholungszeilen
With wks.PageSetup
.PrintTitleRows = "$1:$8" 'Wiederholungszeile
.PrintTitleColumns = ""   'Wiederholungsspalte
End With
'Kopfzeile
ActiveSheet.PageSetup.LeftHeader = "AWO Kreisverband Köln e.V.  *   Rubensstraße 7 - 13   *   50676 Köln"
ActiveSheet.PageSetup.RightHeader = "&D"
ActiveSheet.PageSetup.PrintQuality = 600
ActiveSheet.PageSetup.Zoom = 70
'Seitenzahl
ActiveSheet.PageSetup.RightFooter = "&P/&N"
'Druckbereich_dynamisch
Dim h As Long
h = Range("A65536").End(xlUp).Row
ActiveSheet.PageSetup.PrintArea = "$A$1:$F$" & h
Next
'KST_Namen_zuordnen
Dim wkbaktiv As Workbook
Dim wkz As Worksheet
Dim wksDaten As Worksheet
Dim wkbDaten As Workbook
Dim rnga As Range
On Error GoTo fehler
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Set wkbaktiv = ActiveWorkbook
Workbooks.Open "D:\BAB Kitas\Kostenstellen.xls"
Set wkbDaten = Workbooks("Kostenstellen.xls")
Set wksDaten = wkbDaten.Sheets("Kostenstellen")
For Each wkz In wkbaktiv.Sheets
If wkz.[C3] <> "" Then
Set rnga = wksDaten.Columns("A").Find(What:=wkz.[C3], LookIn:=xlValues, _
LookAt:=xlWhole)
If Not rnga Is Nothing Then
wkz.[D3] = rnga.Offset(0, 1)
wkz.[G3] = rnga.Offset(0, 2)
End If
End If
Next
wkbDaten.Close
fehler:
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Application.ScreenUpdating = True
End Sub