Prüfung ob Tabellenblattname schon vorhanden...

moppi · 2007-08-07T13:03:00+00:00

hi an alle profis, habe ein problem... habe eine sog. masterdatei (A) in der ich daten eingebe und über einen button das aktuelle tabellenblatt in eine externe datei (B) exportiere. dabei wird B geöffnet, das tabellenblatt herüberkopiert und der wert aus zelle A8 als tabellenblattname verwendet. nun zum problem: wie kann ich beim kopieren und umbenennen eine prüfung einbauen, dass wenn der name schon vorhanden ist eine eingabeaufforderung erscheint, welche vom nutzer die manuelle namensvergabe des blattes fordert? vielen dank schonmal vorab für eure AW's gruß moppi

Hallo
... den schon sehr guten Code etwas zu modifizieren und zu kommentieren :-)

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
    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
    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
            Exit For
        End If
    Next
    If BoOffen = False Then
        Set targetWkb = Workbooks.Open(Filename:="C:\neu.xls")
        '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
    'Die Else-Anweisung ist nicht nötig
    ' GoTo weiter
    ' End If
    'weiter:
    ''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
            'DAS GIBT ES DEFINITIV nicht :-)
            'On Error Resume Next
            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
        'Warum nochmals prüfen
        'das hast du doch oben schon gemacht
        '----
        'For Each ws1 In Workbooks("neu.xls").Worksheets
        'If ws1.Name = n Then
        'MsgBox ("Name bereits vergeben! Bitte anderen Namen wählen!")
        'GoTo nochmal
        'End If
        'Next ws1
        '----
        'umbenennen
        .Name = TarShName
        '...und gleich in die Zielmappe kopieren
        .Copy Before:=targetWkb.Sheets(1)
    End With
    'Zielmappe schliessen
    With targetWkb
        .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

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

Prüfung ob Tabellenblattname schon vorhanden...

Forumthread: Prüfung ob Tabellenblattname schon vorhanden...

31
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial