Option Explicit
'*****************************************************
Sub Excel_LieferscheinSpeichernInOrdnerRangeJ15()
'***
'*** Das aktive Blatt wird in eine neu Arbeitsmappe gespeichert
'*** Zielordner ist c_Pfad_Ordner_KNrs\(Inhalt J15)
'*** Dateiname: Lieferschein_KNR(Inhalt J15)_yyyymmdd_hhnn.xls
'*** (yyyymmdd_hhnn = aktuelles Datum, z.B. 20051101_1253.xls)
Const c_Pfad_KNrs = D:\Test\Test_LieferscheinSpeichernInOrdnerJ15\Kundennummern
Const c_Range_KNr = J15
Dim ws As Worksheet, wb As Workbook
Dim wst As Worksheet, wbt As Workbook
Dim s_Knr As String, x As Long, s As Long, ret As Integer
Dim s_Pfad As String, s_Filename_Full As String
->aktive Mappe, aktives Blatt
Set wb = ActiveWorkbook
Set ws = ActiveSheet
->KNr holen, Leerzeichen vorn und hinten ggf. löschen
s_Knr = Trim(ws.Range(c_Range_KNr).Value)
->Knr prüfen
If s_Knr = Then MsgBox (Kundennummer ist leer.): GoTo AUFRAEUMEN
For x = 1 To Len(s_Knr)
s = Mid(s_Knr, x, 1)
Select Case s
Case 0 To 9->ok
Case Else->nok
MsgBox (Kundennummer-> & s_Knr &-> entspricht nicht dem vorgegebnen Format.)
GoTo AUFRAEUMEN
End Select
Next
->HauptPfad prüfen
If Dir(c_Pfad_KNrs, vbDirectory) = Then
MsgBox (HauptPfad-> & c_Pfad_KNrs &-> nicht vorhanden.): GoTo AUFRAEUMEN
End If
->Pfad für Kundenordner zusammensetzen
If Right(c_Pfad_KNrs, 1) = \ Then
s_Pfad = c_Pfad_KNrs & s_Knr
Else
s_Pfad = c_Pfad_KNrs & \ & s_Knr
End If
->Pfad Kundenordner prüfen
If Dir(s_Pfad, vbDirectory) = Then
ret = MsgBox( _
Kundenordner-> & s_Pfad &-> nicht vorhanden. & vbLf & vbLf & _
Soll der Ordner angelegt werden?, _
vbQuestion + vbDefaultButton2 + vbYesNo)
If ret = vbYes Then
->Pfad anlegen
On Error Resume Next
MkDir s_Pfad
If Err.Number <> 0 Then
Err.Clear
MsgBox (s_Pfad & konnte nicht erstellt werden.)
On Error GoTo 0
GoTo AUFRAEUMEN
End If
On Error GoTo 0
Else
GoTo AUFRAEUMEN
End If
End If
->neuen vollen Dateinamen zusammenstellen
s_Filename_Full = s_Pfad & \Lieferschein_KNR & s_Knr & _ & _
Format(Now(), yyyymmdd_hhnn) & xls
->prüfen, ob Datei bereits vorhanden ist
If Dir(s_Filename_Full, vbNormal) <> Then
->bereits vorhanden, Nachfrage auf überschreiben
ret = MsgBox( _
Datei-> & s_Filename_Full &-> bereits vorhanden. & vbLf & vbLf & _
Soll die Datei überschrieben werden?, _
vbQuestion + vbDefaultButton2 + vbYesNo)
If ret = vbNo Then GoTo AUFRAEUMEN
End If
->*** neue Mappe anlegen
Set wbt = Workbooks.Add
->überflüssige Blätter löschen, bis auf 1.tes
Application.DisplayAlerts = False
For x = wbt.Worksheets.Count To 2 Step -1
wbt.Worksheets(x).Delete
Next
Set wst = wbt.Worksheets(1)
->Lieferscheinblatt in neu Mappe kopieren
ws.Copy After:=wst
->- letztes überflüssiges Blatt löschen
wst.Delete
->- Datei in Kundenordner speichern (ohne Nachfragen)
wbt.SaveAs Filename:=s_Filename_Full
->- Datei schliessen
wbt.Close Savechanges:=False
Application.DisplayAlerts = True
AUFRAEUMEN:
Set ws = Nothing: Set wb = Nothing: Set wst = Nothing: Set wbt = Nothing
End Sub