AW: Arbeitmappe kopieren und umbenennen
26.10.2010 01:25:49
fcs
Hallo Markus,
nachfolgend Makros zur Ausführung der gewünschten Funktionen.
Dateinamen und Verzeichnisse bitte anpassen.
Gruß
Franz
Option Explicit
Dim bKundevorhanden As Boolean, sKunde As String
Private Const sVorlage As String = "C:\Users\Public\Test\Kundendaten.xls" 'Vorlagedatei
Private Const sVerzeichnis As String = "C:\Users\Public\Test\Daten" 'Verzeichnis Kundendateien
Sub CheckAlleNamen()
'Prüfung aller Namen in Tabelle1 in Spalte A ab Zeile 2
Dim Zeile As Long, wks As Worksheet
Set wks = ActiveWorkbook.Worksheets("Tabelle1")
With wks
For Zeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
sKunde = .Cells(Zeile, 1)
If CheckDateiName(sKunde, Zeile) = True Then
Call KundenDatei
End If
Next
End With
End Sub
Sub CheckEinzelName()
'Name in aktiver Zelle prüfen
With ActiveCell
If .Column = 1 And .Row > 1 Then
sKunde = ActiveCell.Value
If CheckDateiName(sKunde) = True Then
If KundenDatei = True Then
If bKundevorhanden = True Then
MsgBox "Für Kundenname """ & sKunde & """ existiert bereits eine Kundendatei."
Else
MsgBox "Kundendatei für """ & sKunde & """ wurde angelegt."
End If
End If
End If
Else
MsgBox "Vor Start des Makros muss ein Kundenname in Spalte A selektiert sein."
End If
End With
End Sub
Private Function KundenDatei() As Boolean
Dim sDateiname As String
On Error GoTo Fehler
'prüfen, ob Kundendatei vorhanden
If VBA.Dir(sVerzeichnis & "\" & sKunde & ".xls*") = "" Then
'Dateiname der Kundendatei
sDateiname = sVerzeichnis & "\" & sKunde & Mid(sVorlage, InStrRev(sVorlage, "."))
'Vorlage kopieren mit neuem Namen
VBA.FileCopy Source:=sVorlage, Destination:=sDateiname
bKundevorhanden = False
Else
bKundevorhanden = True
End If
Fehler:
With Err
Select Case .Number
Case 0
KundenDatei = True
Case Else
KundenDatei = False
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Problem bei Datei für Kunde: " & sKunde
Err.Clear
End Select
End With
End Function
Function CheckDateiName(sText As String, Optional ByVal lZeile As Long = 0) As Boolean
Dim iIndex As Long, arrZeichen, iZeichen As Long
If sText = "" Then 'Leerstring als Dateiname nicht zulässig
CheckDateiName = False
Exit Function
End If
'unzulässige Zeichen in Dateinamen
arrZeichen = Array(":", "|", "/", "\", "", "[", "]", "?", "*")
CheckDateiName = True
For iZeichen = 1 To Len(sText)
For iIndex = LBound(arrZeichen) To UBound(arrZeichen)
If Mid(sText, iZeichen, 1) = arrZeichen(iIndex) Then
CheckDateiName = False
MsgBox "Name """ & sKunde & """" & IIf(lZeile > 0, " in Zeile " & lZeile, "") _
& " ist nicht zulässig als Dateiname." & vbLf _
& "Folgende Zeichen sind nicht zulässig: | : / \ [ ] ? * " _
& vbLf & "Kundendatei für """ & sKunde & """ wurde nichtangelegt."
Exit Function
End If
Next
Next
End Function