Leider noch keine Lösung, aber vielleicht muss ich
30.11.2003 22:28:30
Franz W.
... mich jetzt schämen?!?
Herzliches Hallo an Alle!
Leider geht noch keine der Lösungen. Aber vielleicht ist etwas wichtig, was ich vorhin noch nicht für wichtig gehalten und deshalb nicht geschrieben habe: in den Spalten D und G stehen Formeln zur Berechnung der Zhal die da drin steht (weiß nicht, ob das von Bedeutung ist?!?)
Habe deshalb den Vorschlag von Peter auch so geändert:
If Cells(i, 3) <> "" Then
If Cells(i, 4) <> 0 Or Cells(i, 7) <> 0 Then
... geht aber leider auch nicht.
Es sollen Rechnungen geschrieben werden. Und nun wird eine saubere Rechnung für Barbara geschrieben. Und dann kommt noch eine vertümmelte (weiß noch nicht warum), und dann ist Schluss.
Hier mal der gesamte Code. Die MsgBox, die ich zum Testen anstelle des Ausdruckes gesetzt habe, zeigt beim ersten Durchlauf brav "Barbara", beim zweiten (mit dem verstümmelten Ausdruck), zeigt er plötzlich "Barbara Kowarschik", der Nachname gehört zur Barbara und steht in "M1", keine Ahnung wie der da hinkommt. Vielleicht hat ja noch jemand eine Idee, falls der Code für die sppäte Stunde nicht zu lange ist:
Sub Rechnungen_drucken()
''''''''Rechnungen drucken
Application.ScreenUpdating = False
Dim Fst$, SFst$, Gebuehr As Currency
Dim KdTitel$, KdNr$, KdNName$, KdVName$, KdStr$, KdPLZ$, KdOrt$
Dim ReDat As Date, jZahl$, KalWo$, AbrMon$
Dim EnerHausgPath$, ENPath$, FstPath$
Dim i As Byte
Dim wkb As Workbook, wks As Worksheet
Dim sWb, sWbFs, ReNr$
Dim VorlENFst$
Dim FSo, OrdnerName
VorlENFst = ThisWorkbook.Worksheets("help").[C24]
EnerHausgPath = "C:\Dokumente und Einstellungen\bernhard\Eigene Dateien\ENERGIE_HAUSGEMACHT\"
ENPath = EnerHausgPath & "RechnungenEN\"
jZahl = [a13]
AbrMon = Format([a20], "mmmm")
'## Prüfen, ob alle Adressen eingetragen sind:
For i = 1 To 14
If Cells(i, 3) <> "" And Cells(i, 11) = "" Then
MsgBox Chr(13) & _
"Bei "" " & Cells(i, 3).Value & " "" ist die Adresse noch nicht eingetragen " _
& Chr(13) & Chr(13), 16
Exit Sub
End If
Next
'## Sicherheitsabfrage:
If MsgBox(Chr(13) & "Sollen die Rechnungen jetzt gedruckt werden? " & Chr(13) & " ", 65, _
"Fahrstundenabrechnungen") = vbCancel Then Exit Sub
'## Zelle mit Ausgangsdatum sperren:
Worksheets("Fahrstunden").Unprotect
With Range("A15")
If Not .Comment Is Nothing Then .ClearComments
.Locked = True
.FormulaHidden = False
End With
Worksheets("Fahrstunden").Protect
'## Rechnungen drucken:
'## Prüfen ob "KUNDENDATEN.xls" schon offen:
On Error Resume Next
Set sWb = Workbooks("KUNDENDATEN.xls")
If Not IsObject(sWb) Then Workbooks.Open _
Filename:=EnerHausgPath & "KUNDENDATEN.xls"
On Error GoTo 0
Set sWb = Nothing
'## Prüfen ob "RECHNUNGEN_EN.xls" schon offen:
On Error Resume Next
Set sWbFs = Workbooks("RECHNUNGEN_EN.xls")
If Not IsObject(sWbFs) Then Workbooks.Open _
Filename:=ENPath & "RECHNUNGEN_EN.xls"
On Error GoTo 0
Set sWbFs = Nothing
Workbooks("RECHNUNGEN_EN.xls").Worksheets("Offene").Unprotect
'## Erstellung der Variablen für ReNr:
Set wkb = Workbooks("KUNDENDATEN.xls")
Set wks = wkb.Worksheets("Help")
'## Hier geht's los:
Workbooks(ThisWorkbook.Name).Sheets("Fahrstunden").Activate
For i = 1 To 14
If Cells(i, 3) <> "" Then
If Cells(i, 4) <> 0 Or Cells(i, 7) <> 0 Then
KdVName = Cells(i, 3)
KdNr = Format(Cells(i, 11), "000")
KdTitel = Cells(i, 12)
KdNName = Cells(i, 13)
KdStr = Cells(i, 14)
KdPLZ = Cells(i, 15)
KdOrt = Cells(i, 16)
Fst = Cells(i, 4)
SFst = Cells(i, 7)
' Gebuehr = Format(Cells(i, 9), "0.00")
Gebuehr = Cells(i, 9)
ReDat = Date
'## Rechnungsnummer auslesen:
ReNr = wks.Cells(9, 12).Value
'## Rechnungsnummer hochzählen:
wks.Cells(9, 10).Value = wks.Cells(9, 10).Value + 1
Application.ScreenUpdating = False
'### Neue Datei mit Vorlage EN_ReVorlageFS.xlt :
Workbooks.Add Template:=VorlENFst
With Workbooks("EN_ReVorlageFS1")
With .Worksheets("Fahrstundenrechnung")
.Unprotect
.Range("C6").Value = KdTitel
.Range("D6").Value = KdNName
.Range("E6").Value = KdVName
.Range("C9").Value = KdStr
.Range("C12").Value = KdPLZ
.Range("D12").Value = KdOrt
.Range("H7").Value = ReDat
.Range("H8").Value = ReNr
.Range("H9").Value = KdNr
.Range("E17").Value = AbrMon
.Range("C21").Value = Fst
.Range("C22").Value = SFst
.Range("H23").Value = Gebuehr
.Protect
'## Drucken der Datei:
'# Ausdruck mit Standarddrucker:
MsgBox KdVName
' .PrintOut ActivePrinter:=GetDefaultPrinter
End With
'## Neue Datei speichern:
'' Prüfen ob Ordner ...\jZahl\ existiert
Set FSo = CreateObject("Scripting.FileSystemObject")
OrdnerName = ENPath & jZahl & "\"
If Not FSo.FolderExists(OrdnerName) Then
' Ordner ...\jZahl\ erstellen
MkDir ENPath & jZahl & "\"
End If
FstPath = ENPath & jZahl & "\"
'## Prüfen ob Ordner ...\jZahl\Fahrstunden\ existiert
Set FSo = CreateObject("Scripting.FileSystemObject")
OrdnerName = FstPath & "Fahrstunden\"
If Not FSo.FolderExists(OrdnerName) Then
' Ordner ...\jZahl\Fahrstunden\ erstellen
MkDir FstPath & "Fahrstunden\"
End If
FstPath = FstPath & "Fahrstunden\"
'## Mit "Replace" die Punkte verschwinden lassen, damit sie nicht im Dateinnamen drin sind:
KdTitel = Replace(KdTitel, ".", "")
KdNName = Replace(KdNName, ".", "")
KdVName = Replace(KdVName, ".", "")
'## Speichern im Ordner ...\FstPath\
.SaveAs FstPath & _
"KW " & KalWo & _
ReNr & " " & KdNr & " " & KdTitel & " " & KdNName & " " & KdVName & ".xls"
'## Speichern und schließen:
Application.ScreenUpdating = False
' .Close SaveChanges:=True
End With
End If
End If
Next
Application.ScreenUpdating = False
With Workbooks("RECHNUNGEN_EN.xls")
.Worksheets(2).Activate
.Worksheets("Offene").Activate
.Worksheets("Offene").Protect
.Save
' .Close SaveChanges:=True
End With
Workbooks(ThisWorkbook.Name).Sheets("Fahrstunden").Activate
End Sub
Herzlichen Dank und beste Grüße
Frarnz