AW: Makro-Start mit Hilfe eines Icons
11.11.2003 14:06:18
John
Hey, das ging flott, schon mal herzlichen Dank!
Hier die Makros, so wie sie im Original ablaufen:
Sub KontrolldateiB()
'
' Makro1 Makro
' Makro am 15.02.2002 von Johann Kopp, Tel. 4 35 41 aufgezeichnet
'
'
On Error GoTo ende
Workbooks.OpenText FileName:=Application.Dialogs(xlDialogOpen).Show("c:\temp\Kon*.txt"), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2))
ende:
End Sub
Sub ZeileFettWennKnotenPB()
'
' ZeileFettNeu Makro
' Makro am 13.01.2000 von Johann Kopp aufgezeichnet
'
GuV_KnotenLöschenB
b2brain_formatierenB
Do While ActiveCell.Value <> ""
If ActiveCell.Characters(Start:=1, Length:=1).Text = "P" Then
' If ActiveCell.Characters(Start:=1, Length:=1).Value = "P" Then
selection.EntireRow.Font.Bold = True
ActiveCell.Offset(1, 0).Range("A1").Select
Else
ActiveCell.Offset(1, 0).Range("A1").Select
End If
Loop
' b2BrainDruckvorbereitung
End Sub
Sub ZeilenAusblendenAlleSpaltenNullB()
Dim Alpha As String
Dim i As Integer
Application.ScreenUpdating = False
GuV_KnotenLöschenB
b2brain_formatierenB
Rows("2:2").Select
selection.Insert Shift:=xlDown
Range("A3:F3").Select
selection.AutoFilter
selection.AutoFilter Field:=6, Criteria1:="<>"
i = 5
Do Until zähler > 5
Alpha = Cells(i, 1)
Alpha = Left(Alpha, 1)
'Blank = Cells(i, 3) & Cells(i, 4) & Cells(i, 5)
If Left(Cells(i, 2), 1) = " " And Mid(Cells(i, 2), 2, 1) <> " " Then
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Rows(i)
End If
' If UCase(Alpha) = "K" Or UCase(Alpha) = "P" Then
' If Blank = "" Then
' Cells(i, 1).EntireRow.Hidden = True
' zähler = 0
' End If
' If Cells(i, 1).EntireRow.Hidden = True Then
' GoTo weiter
' End If
If UCase(Alpha) = "P" Then
Cells(i, 1).Select
Cells(i, 1).EntireRow.Font.Bold = True
zähler = 0
End If
If UCase(Alpha) = "" Then
zähler = zähler + 1
End If
i = i + 1
weiter:
If Rows(i).EntireRow.Hidden = True Then
i = i + 1
GoTo weiter
End If
'Debug.Print i
Loop
Application.ScreenUpdating = True
KopfzeileB
b2BrainDruckvorbereitungB
End Sub
Sub ZeilenAusblendenKontenzeilenB()
Dim Alpha As String
Dim i As Integer
Application.ScreenUpdating = False
zähler = ActiveCell.SpecialCells(xlLastCell).Row
i = 1
Do Until i = zähler + 1
Alpha = Cells(i, 1)
Alpha = Left(Alpha, 1)
If UCase(Alpha) <> UCase("p") Then
Cells(i, 1).EntireRow.Hidden = True
End If
' If UCase(Alpha) = "P" Then
' Cells(i, 1).Select
' Selection.EntireRow.Font.Bold = True
' Zähler = 0
' End If
If UCase(Alpha) = "" Then
End If
i = i + 1
Loop
Application.ScreenUpdating = True
End Sub
Private Sub b2brain_formatierenB()
Columns("A:A").Select
With selection.Font
.Name = "Courier"
.Size = 11
.ColorIndex = xlAutomatic
End With
'alle Spalten in der Breite autom. anpassen
Columns("A:B").EntireColumn.AutoFit
'Die Breite der Werte-Spalten einstellen
Columns("C:R").Select
selection.NumberFormat = "#,##0.00 ;[red](#,##0.00) ; ; @ "
With selection
.WrapText = True
' .Orientation = 0
' .ShrinkToFit = False
End With
Columns("C:F").ColumnWidth = 17
Columns(1).ColumnWidth = 15.33
'Spaltenüberschriften gelb hinterlegen
Rows("2:2").Select
With selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
selection.Font.Bold = True
End Sub
Private Sub b2BrainDruckvorbereitungB()
Application.ScreenUpdating = False
Range("A1").Select
'Wiederzolungszeilen einrichten
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$4"
End With
ScreenUpdating = True
'Seite einrichten und in der Druckvorschau anzeigen
With ActiveSheet.PageSetup
.LeftFooter = "&""FuturaA Bk BT,Book""&8ZK/LBF, &D"
.CenterFooter = "&8Seite &P von &N"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.3)
.RightMargin = Application.InchesToPoints(0.3)
.TopMargin = Application.InchesToPoints(0.7)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.7)
.FooterMargin = Application.InchesToPoints(0.1)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 93
.FitToPagesWide = False
.FitToPagesTall = False
End With
'Die Überschriften über den Werte-Spalten rechts aurichten
Range("c4", "f4").HorizontalAlignment = xlRight
Cells(1, 1).EntireColumn.Font.Bold = False
Range("A3").Font.Bold = True
On Error Resume Next
ActiveSheet.HPageBreaks(1).Delete
With Cells(1, 1).Font
.Name = "FuturaA Bk BT"
.Bold = True
.Size = 11
.ColorIndex = xlAutomatic
.Bold = True
End With
Range("f4").Select
selection.End(xlDown).Select
letzteZelle = ActiveCell.Address
ActiveSheet.PageSetup.PrintArea = "A$1 : " & letzteZelle
ActiveWindow.SelectedSheets.PrintPreview
End Sub
Private Sub ÖffnenDialog()
Application.Dialogs(xlDialogOpen).Show ("c:\Temp\kon*.txt")
End Sub
Private Sub GuV_KnotenLöschenB()
Application.ScreenUpdating = False
On Error GoTo ende
Cells.Find(What:="pbilanzko", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
zeilest = ActiveCell.Address
zeileen = ActiveCell.SpecialCells(xlLastCell).Address
Range(zeilest, zeileen).Select
selection.EntireRow.Delete
ende:
End Sub
Private Sub KopfzeileB()
' Es wird eine leere Zeile 1 eingfügt und formatiert
Range("A1").Select
On Error Resume Next
selection.EntireRow.Insert
Range("A1").Select
With selection.Font
.Name = "FuturaA Bk BT"
.Bold = True
' .FontStyle = "Book"
.Size = 11
.ColorIndex = xlAutomatic
.Bold = True
End With
' Der Wert für die Überschrift wird abgefragt
Dim mldg, titel, wert
titel = "Überschrift 1. Zeile"
mldg = "Bilanz ... "
Voreinstellung = "Axxxx , 30. September 2003 "
wert = InputBox(mldg, titel, Voreinstellung, 5000, 5000)
Range("A1").Value = "Bilanz " & wert
End Sub
Sub A_Kontrolldatei_AuswahlB()
GoTo Start
ende:
Exit Sub
Start:
'
ChDrive "c:\" '
ChDir "c:\temp\"
Dir ("c:\temp\*.txt")
On Error GoTo ende
Workbooks.OpenText FileName:=Application.GetOpenFilename("Textdateien (*.txt), c:\temp\kon*.txt"), Origin:= _
xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=True, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1))
ZeilenAusblendenAlleSpaltenNullB
End Sub