AW: Makro mit Auswahl
15.01.2007 13:36:51
fcs
Hallo rupi,
folgende Anpassung der Prozedur sollte die in Spalte J mit einem X markierten Anträge drucken. Ich hab dabei entsprechende Variablen deklariert und die Kopieraktionen durch direkte Wertzuweisungen ersetzt.
Gruß
Franz
Sub Urlaub1()
' Urlaub1 Makro
' Makro am 08.01.2007 von 67adrupp aufgezeichnet
Dim wbForm As Workbook, wbAktiv As Workbook, wksAktiv As Worksheet, wksForm As Worksheet
Dim Zelle As Range, Zeile As Long
Set wbAktiv = ActiveWorkbook
Set wksAktiv = ActiveSheet
With wksAktiv
For Each Zelle In .Range("J8:J28") ' Bereich in dem X für Auswahl eingetragen wird
If UCase(Zelle.Value) = "X" Then
Zeile = Zelle.Row
Range("A13").Select ' Kopiert die Daten in das Formular
Selection.Copy
Set wbForm = Workbooks.Open(Filename:= _
"C:\Dokumente und Einstellungen\67adrupp\Eigene Dateien\urlaub\Formular-blanko.xls")
Set wksForm = ActiveSheet
wksForm.Range("A20").Value = .Cells(Zeile, "A").Value
wksForm.Range("B20").Value = .Cells(Zeile, "B").Value
wksForm.Range("D20").Value = .Cells(Zeile, "F").Value
' Sichert das Formular unter neuen Namen
wbForm.SaveAs Filename:="c:\Dokumente und Einstellungen\67adrupp\Eigene Dateien\urlaub\" _
& .Cells(Zeile, "C").Value & ".xls"
wksForm.PrintOut Copies:=1, Collate:=True ' druckt den Antrag
wbForm.Close ' schließt den Antrag
.Cells(Zeile, "I") = Date
End If
Next
ActiveSheet.Shapes.AddShape(msoShapeExplosion2, 493.5, 18#, 194.25, 159.75). _
Select ' blendet ein fertig Symbol ein
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 10
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.Characters.Text = "" & Chr(10) & "" & Chr(10) & "FERTIG"
With Selection.Characters(Start:=1, Length:=8).Font
.Name = "Arial"
.FontStyle = "Standard"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 6
End With
newHour = Hour(Now()) ' soll 10 sec. warten
newMinute = Minute(Now())
newSecond = Second(Now()) + 5
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
Selection.Delete ' löscht das fertig Symbol wieder
Range("H6").Select
wbAktiv.SaveAs , FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False ' sichert das Urlaub 2007 Dokument
End Sub