AW: Makros in Mappe1 verfügbar machen
Andreas
Hi Matthias!
So was ähnliches habe ich schon, dank dieses Forums. Kann ich das gleich benutzen?
Ich habe halt leider wenig Ahnung von VBA.
Sub Menü_einfügen()
Dim NeuesMenue As CommandBar, St As CommandBarButton, Pop1 As CommandBarPopup
On Error Resume Next
Application.CommandBars("MeineLeiste").Delete
On Error GoTo 0
Set NeuesMenue = CommandBars.Add(Name:="MeineLeiste", temporary:=True)
With NeuesMenue
.Position = msoBarTop
.Visible = True
End With
Set Pop1 = NeuesMenue.Controls.Add(Type:=msoControlPopup)
Pop1.Caption = "Tools"
Set St = Pop1.Controls.Add(Type:=msoControlButton, ID:=1)
With St
.Caption = "Druckbereich für Gravur festlegen"
.Style = msoButtonCaption
.OnAction = "Makro_1"
End With
Set St = Pop1.Controls.Add(Type:=msoControlButton, ID:=1)
With St
.Caption = "Druckbereich wieder normal"
.Style = msoButtonCaption
.OnAction = "Makro_2"
End With
Set St = Pop1.Controls.Add(Type:=msoControlButton, ID:=1)
With St
.Caption = "einblenden der Datenspalten"
.Style = msoButtonCaption
.OnAction = "Makro_3"
End With
Set St = Pop1.Controls.Add(Type:=msoControlButton, ID:=1)
With St
.Caption = "ausblenden der Datenspalten"
.Style = msoButtonCaption
.OnAction = "Makro_4"
End With
Set St = Pop1.Controls.Add(Type:=msoControlButton, ID:=1)
With St
.Caption = "Überweisungsbeträge Zählen"
.Style = msoButtonCaption
.OnAction = "Makro_5"
End With
Set St = Pop1.Controls.Add(Type:=msoControlButton, ID:=1)
With St
.Caption = "VorOrt-Listen einblenden"
.Style = msoButtonCaption
.OnAction = "Makro_6"
End With
'und so weiter und so fort
End Sub
Sub Makro_1()
MsgBox "Blendet alle Schüler ohne Gravur aus und verändert den Druckbereich auf A1:I48"
'ändern des Druckbereiches auf den Bereich "A1:I48!
'ausblenden der Zeilen ohne Gravur
'Bildschirmaktualisierung unterdrücken
Application.ScreenUpdating = False
For z = 1 To 20
With Worksheets(z)
.PageSetup.PrintArea = "$A$1:$i$48"
.PageSetup.Orientation = xlPortrait
.Unprotect
For i = 11 To 46
If .Cells(i, 26) <> 1 And .Cells(i, 27) <> 1 Then
.Rows(i).Hidden = True
End If
Next i
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End With
Next z
Sheets(1).Select
Range("A11").Select
' Bildschirmaktualisierung wieder einschalten
Application.ScreenUpdating = True
MsgBox "Fertig! Die Gravurlisten können jetzt gedruckt werden"
End Sub
Sub Makro_2()
MsgBox "Blendet wieder alle Schüler ein und legt den Druckbereich auf A1:T48 fest"
'Bildschirmaktualisierung unterdrücken
Application.ScreenUpdating = False
Dim i As Integer
For i = 1 To 20
With Sheets(i)
.Unprotect
.Rows("11:46").Hidden = False
.PageSetup.PrintArea = "$A$1:$T$48"
.Protect
End With
Next i
'Bildschirmaktualisierung wieder einschalten
Application.ScreenUpdating = True
Sheets(1).Select
Range("A11").Select
MsgBox "Fertig!"
End Sub
Sub Makro_3()
MsgBox "Es werden die Spalten sichtbar, in denen sich Berechnungswerte befinden. Bevor diese Werte verändert werden, sollte eine Sicherungskopie angelegt werden!"
'Blendet die Datenspalten im aktiven Blatt ein
ActiveSheet.Unprotect
Columns("U:BK").Select
Selection.EntireColumn.Hidden = False
Range("A11").Select
End Sub
Sub Makro_4()
MsgBox "Datenspalten wieder ausblenden"
'ausblenden der Datenspalten im aktiven Blatt
ActiveSheet.Unprotect
Columns("V:BJ").Select
Selection.EntireColumn.Hidden = True
Range("A11").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
Sub Makro_5()
MsgBox "Es werden jetzt alle Überweisungsbeträge gezählt und das Blatt 'Einzelüberweisungen' wird eingeblendet"
'Zählt die verschiedenen Preise und deren Anzahl zum ausfüllen
'der Einzelüberweisungsträger und sortiert die Werte
Dim i%, c As Range, r As Range
ActiveWorkbook.Unprotect
Sheets("Einzelüberweisungen").Visible = True
With Worksheets("Einzelüberweisungen")
Sheets("Einzelüberweisungen").Select
Range("A3").Select
ActiveSheet.Unprotect
.Range("A3:B900").ClearContents
For i = 1 To 20
For Each c In Worksheets(i).Range("T11:T46")
If IsNumeric(c.Value) And Not c.Value = 0 Then
Set r = .Range("A3:A723") _
.Find(What:=c.Value, LookIn:=xlFormulas, LookAt _
:=xlWhole)
If Not r Is Nothing Then
r.Offset(0, 1).Value = r.Offset(0, 1).Value + 1
Else
Set r = .Range("A65536").End(xlUp)
If r.Row = 1 Then Set r = .Range("A2")
r.Offset(1, 0).Value = c.Value
r.Offset(1, 1).Value = 1
End If
End If
Next c
Next i
End With
Range("A3:B50").Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A3:B50").Select
Selection.NumberFormat = "#,##0.00 [$-1]"
Range("A3").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ActiveWorkbook.Protect Structure:=True, Windows:=False
End Sub
Sub Makro_6()
MsgBox "Die VorOrt-Listen werden eingeblendet"
'blendet 2 VorOrt-Listen ein
ActiveWorkbook.Unprotect
Sheets("VorOrtÜberweisungslisten").Visible = True
Sheets("VorOrtAbrechnung").Visible = True
End Sub
Danke für die Hilfe!
mfg, Andreas