AW: entfernen Private Sub über VB
09.01.2005 17:31:22
Korl
Hallo Sepp,
ich hab's geahnt, das ist zu hoch für mich. Versucht habe ich es mit der "call" Funktion. Das hat nicht funktioniert.
Hier mal mein gesamter Code
Sub Archivieren()
If Worksheets("Rechnung").Range("F52") = 0 Then
Debug.Print MsgBox("Es wurde noch keine Rechnung erstellt!", 64, "Hinweis")
End If
' erst beginnen wenn der Rechnungsbetrag >0 ist
If Worksheets("Rechnung").Range("F52") > 0 Then
' Bildschirm ausschalten
Application.ScreenUpdating = False
' Name der neuen Arbeitsmappe
Datname = Range("B21")
' aktuelle Zeile für den Eintrag in das Blatt Rechnungen
Aktzeile = Range("C21")
' aktuelles Datum
Aktdat = Range("F26")
' aktuelle Kundennummer
Aktknr = Range("F25")
' Anrede des Kunden
Kundanrede = Range("B14")
' Vorname und Name des Kunden
Kundname = Range("B15")
' Zusatz zum Kunden
Aktzusatz = Range("B16")
' Straße des Kunden
Kundstras = Range("B17")
'Wohnort des Kunden
Kundort = Range("B18")
Smeter = Range("B48")
' Nettobetrag der aktuellen Rechnung
Kundnetto = Range("F49")
' Mwst.-Betrag der aktuellen Rechnung
Kundmwst = Range("F50")
' Bruttobetrag der aktuellen Rechnung
Kundbrutto = Range("F52")
' Neue Arbeitsmappe mit einem Tabellenblatt anlegen
With Application
.SheetsInNewWorkbook = 1
End With
Workbooks.Add
' Neue Arbeitsmappe speichern (Dateiname = Rechnungsnummer)
' In Nachfolgezeile kann der Pfad korrigiert werden
ActiveWorkbook.SaveAs FileName:= _
"C:\Programme\Verein\Archiv-Rechnungen\" & Datname, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
With Application
.SheetsInNewWorkbook = 5
End With
' Wechseln auf das Original-Rechnungsblatt
Windows("Sägerei Felten.xls").Activate
Sheets("Rechnung").Select
' verschiebt das Blatt "Ausdruck" in die neue Mappe "Datname"
Sheets("Rechnung").Copy Before:=Workbooks(Datname).Sheets(1)
ActiveWindow.FreezePanes = False
'Blattschutz aufheben
Sheets("Rechnung").Select
With Sheets("Rechnung")
.Unprotect Password:="xxx"
.Protect Contents:=True, UserInterfaceOnly:=True, Password:="xxx"
End With
'Kopiert und fügt nur Werte und Formate ein, sperrt komplett
Cells.Select
Selection.Locked = True
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Rows("1:2").Select
Selection.Delete Shift:=xlUp
Range("B31").Select
Application.DisplayAlerts = 0
Sheets("Tabelle1").Delete
Application.DisplayAlerts = 1
HIER HABE ICH's mit "call" versucht
' speichert und schließt die neue Mappe
ActiveWindow.SmallScroll Down:=-23
ActiveWorkbook.Save
ActiveWorkbook.Close
' Daten der ausgefüllten Rechnung im Tabellenblatt Liste ablegen
Range("H7").Select
Sheets("Liste").Select
Cells(Aktzeile, 2).Formula = Aktdat
Cells(Aktzeile, 3).Formula = Aktknr
Cells(Aktzeile, 4).Formula = Kundnetto
Cells(Aktzeile, 5).Formula = Kundmwst
Cells(Aktzeile, 6).Formula = Kundbrutto
Cells(Aktzeile, 11).Formula = Kundanrede
Cells(Aktzeile, 12).Formula = Kundname
Cells(Aktzeile, 13).Formula = Kundzusatz
Cells(Aktzeile, 14).Formula = Kundstras
Cells(Aktzeile, 15).Formula = Kundort
Cells(Aktzeile, 16).Formula = Smeter
'Original-Rechnung leeren
Sheets("Rechnung").Select
Range("B33:E46").Select
Selection.ClearContents
Range("B33").Select
' Blidschirmaktualisierung einschalten
Application.ScreenUpdating = True
Sheets("Liste").Select
Application.DisplayFormulaBar = True
End If
End Sub
Sepp, ich weiß es ist alles etwas Laienhaft gestrickt, aber ich freue mich immer wieder wenns klappt.
Kann man da was machen?
Gruß Korl