Bereich kopieren und Name prüfen

Hallo,
ich möchte einen Bereich aus einer Tabelle kopieren und in eine neue Tabelle der aktuellen Arbeitsmappe an letzter position als Werte einfügen.
Das geht ganz gut, aber jetzt soll er überprüfen ob es diese Tabelle mit den Namen, das ich vorher aus der Quelltabelle der Zelle A1 übernommen habe, es schon gibt.
Die Reihefolge stimmt hier nicht, bekomme es aber nicht hin!
Kann jemand von euch mal drüber schauen!!
Vielen Dank im voraus
Gruß Andi

Sub KopiereBereich()
Dim Quelltab As Worksheet
Dim Zieltab As Worksheet
Dim Zelle As Range
Dim MyName$, x&
Set Quelltab = ActiveWorkbook.Worksheets("Tabelle1")
Worksheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = Worksheets("Tabelle1").Range("A1").Value
Quelltab.Range("A8:H30").Copy
ActiveSheet.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ActiveSheet.Cells(1, 1).Select
MyName = Quelltab.Range("A1").Text
On Error GoTo ErrExit
For x = 1 To Worksheets.Count
If Worksheets(x).Name = MyName Then
MsgBox "Dieses Blatt existiert schon", vbCritical
Exit Sub
End If
Next
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = MyName
Exit Sub
ErrExit:
MsgBox "es ist ein Fehler augfgetreten evtl. sind ungültige Zeichen im Namen", vbInformation
Application.DisplayAlerts = False
Sheets(Sheets.Count).Delete
Application.DisplayAlerts = True
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub test() Dim o As Object, o1 As Variant Dim sh As Worksheet Dim neuerName As String Dim i As Long Dim ois_ok As Boolean Const verboten = "/\*:?[]" neuerName = Worksheets("Tabelle1").Range("A1").Value If Trim(neuerName) = "" Or neuerName = "Tabelle1" Then ois_ok = False Else ois_ok = True End If For i = 1 To Len(neuerName) If InStr(neuerName, Mid(verboten, i, 1)) > 1 Then ois_ok = False Exit For End If Next If Not ois_ok Then MsgBox "Falscher Blattname" Exit Sub End If Set o = CreateObject("scripting.dictionary") For Each sh In Worksheets o(sh.Name) = 1 Next If o(neuerName) = 1 Then MsgBox "Hier Dein Code wenn Blatt existiert." & vbLf & "Also, evtl. Bereich löschen." Else MsgBox "Hier Dein Code wenn nicht da..." & vbLf & "Also neues Blatt anlegen." Sheets.Add after:=Sheets(Sheets.Count) Sheets(Sheets.Count).Name = neuerName End If ' dann kopieren und Ende Worksheets("Tabelle1").Range("A8:H30").Copy Worksheets(neuerName).Cells(1, 1).PasteSpecial Paste:=xlPasteValues End Sub

Beliebteste Forumthreads (12 Monate)

Bereich kopieren und Name prüfen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread