Korrektur
08.08.2007 10:59:00
Ramses
Hallo
Hier noch die Variante wo der Pfad ebenfalls als Variable angegeben werden muss.
Dann musst du nur noch die beiden Punkte anpassen und im Code selber nichts mehr ändern
Option Explicit
Sub namen()
'Aussagekräftige Variablennamen sind wichtig
'um sich später in einem Code zurechtzufinden
'Gross und Kleinschreibung verwenden
'Im Code die Variablen nur kleinschreiben
'Wenn Sie richtig geschrieben sind
'wechselt EXCEL die Buchstaben korrekt in Grossbuchstaben um
'Das ist eine einfache Kontrolle auf Schreibfehler :-)
Dim sourceWkb As Workbook, targetWkb As Workbook
Dim targetWkbName As String, targetPfad As String
Dim sourceWks As Worksheet, targetWks As Worksheet
Dim wks As Worksheet, wkb As Workbook
Dim TarShName As String, newTarShName As String
Dim BoOffen As Boolean
'****************
'Anpassen Zielmappe
'Pfad mit Backslash am Ende
targetPfad = "C:\"
targetWkbName = "Neu.xls"
'Ab hier muss eigentlich nichts mehr geändert werden
'****************
Set sourceWkb = ThisWorkbook
Set sourceWks = sourceWkb.ActiveSheet
TarShName = sourceWks.Range("A8")
BoOffen = False
For Each wkb In Workbooks
If wkb.Name = targetWkbName Then
BoOffen = True
Set targetWkb = Workbooks(targetWkbName)
Exit For
End If
Next
If BoOffen = False Then
Set targetWkb = Workbooks.Open(Filename:=targetPfad & targetWkbName)
'Alternativ um flexibel zu sein
'targetWkbName = Application.GetOpenFilename("XLS Dateien (*.xls),", True, "Neue Zieldatei auswählen", "Übernehmen", False)
'Set targetWkb = Workbooks.Open(Filename:=targetWkbName)
End If
'Worksheets bezieht sich NUR auf Worksheets, andere Blätter
'wie Diagramme usw. belegen aber auch einen Namen
'Daher ist die Prüfung ALLER Blätter nötig
'Mit Verweis auf die oben erstellten Objecte fällt es leichter
'den Code zu kontrollieren und ausserdem listet dir EXCEL
'in der Autovervollständigung die möglichen Methoden auf
GoTo StartLoop
'----------------------------
'Dieser Einsprungpunkt brauchen wir wenn
'ein neuer Name angefordert wird
Restart:
newTarShName = InputBox("Neuen Namen eingeben!", "Tabellenname existiert bereits")
'Sehr gut abgefangen :-)
If StrPtr(newTarShName) = 0 Then
Exit Sub
End If
If Len(newTarShName) > 31 Then
'Benutzerhinweis :-)
MsgBox "Name zu lang!", vbInformation + vbOKOnly, "Zeichenlänge max 31 Zeichen"
GoTo Restart
End If
'Gut nachgedacht :-)
If newTarShName = "" Then
MsgBox "Bitte mindestens 1 Zeichen eingeben", vbInformation + vbOKOnly, "Kein Namen angegeben"
GoTo Restart
End If
'... die Prüfung auf unerlaubte Zeichen :-)
If CheckName(newTarShName) = True Then
GoTo Restart
End If
'Alte Variable neu füllen
TarShName = newTarShName
'-----------------------------
'Und hier beginnt die normale Routine
StartLoop:
'Bei einem neuen Namen muss die Mappe
'ebenfalls nochmals komplett neu geprüft werden
For Each wks In targetWkb.Sheets 'Worksheets
If wks.Name = TarShName Then
MsgBox "Blattname existiert in der Zieldatei schon! Geben Sie einen anderen Namen ein!", vbInformation + vbOKOnly, "Namen Fehler"
GoTo Restart
End If
Next wks
'Hier greifen wir bereits auf das oben
'erstellte Tabellenobject zu
'So geht es einfacher :-)
With sourceWks
'...und gleich in die Zielmappe kopieren
.Copy Before:=targetWkb.Sheets(1)
End With
'Zielmappe schliessen
With targetWkb
.Sheets(1) = TarShName
.Save
.Close
End With
End Sub
Function CheckName(chkString As String) As Boolean
'(C) Ramses
'Gibt "True" zurück, wenn ein unerlaubtes
'Zeichen im Namen vorhanden ist
'False wenn alles korrekt ist
Dim i As Integer
For i = 1 To Len(chkString)
Select Case Mid(chkString, i, 1)
Case "\", "/", ">", "<", ":", "*", "?", "[", "]", "¦"
MsgBox ("Unerlaubtes Zeichen """ & Mid(chkString, i, 1) & """ an Position " & i & " in " _
& """" & chkString & """" & vbCrLf _
& vbCrLf & "Kopiervorgang wegen Fehler in Dateinamen abgebrochen")
CheckName = True
Exit Function
End Select
Next i
CheckName = False
End Function
Gruss Rainer
