Neue Arbeitsblatt

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Vielen Dank Michael..passt perfekt!
ich habe noch eine Frage und Zwar wie können die Daten aus der Zwischenablge in disem bestimmten Bereich kopiert werden und nach dem Enter-Drucken, werden die in diesem bestimmten Bereich hinzugefügten datein entsprechenden Namen die neue Blätter erzeugt werden..
Was soll ich in deinem Makro ändern?

Sub VorlageKopieren(wsBez As String)
Dim i As Integer
Dim Weiter As Boolean
Application.ScreenUpdating = False
Weiter = False
wsBez = Replace(wsBez, ":", "")
wsBez = Replace(wsBez, "\", "")
wsBez = Replace(wsBez, "/", "")
wsBez = Replace(wsBez, "?", "")
wsBez = Replace(wsBez, "*", "")
wsBez = Replace(wsBez, "[", "")
wsBez = Replace(wsBez, "]", "")
With ThisWorkbook
For i = 1 To .Sheets.Count
If LCase(.Worksheets(i).Name) = LCase(wsBez) Then
MsgBox "Dieses Blatt existiert bereits!"
Exit Sub
End If
Next
Select Case Len(wsBez)
Case Is > 31
wsBez = Left(wsBez, 31)
Case Is = 0
If MsgBox("Zelle ist leer - Standardname für neues Blatt vergeben?",  _
vbYesNo) = vbYes Then _
Weiter = True
Case Else
wsBez = wsBez
End Select
.Worksheets("Vorlage").Copy After:=Sheets(.Sheets.Count)
If Weiter Then
.ActiveSheet.Name = "Blatt " & .Sheets.Count + 1
Else: .ActiveSheet.Name = wsBez
End If
End With
Worksheets("Steuerung").Activate
Application.ScreenUpdating = True
End Sub

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim bereich As Range If Target.Count > 1 Then Exit Sub Set bereich = Range("B1:B2") '---erweiterbar If Not Intersect(Target, bereich) Is Nothing Then If Not SheetExist(Target) Then Worksheets("Vorlage").Copy after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Target Else MsgBox "Blattname schon vorhanden", vbInformation End If End If End Sub Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean Dim wks As Worksheet On Error GoTo ERRORHANDLER If Wb Is Nothing Then Set Wb = ThisWorkbook For Each wks In Wb.Worksheets If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function Next ERRORHANDLER: SheetExist = False End Function

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim bereich As Range If Target.Count > 1 Then Exit Sub Set bereich = Range("B1:B2") '---erweiterbar If Not Intersect(Target, bereich) Is Nothing And Target "" Then If IsError(Evaluate(Target & "!A1")) Then '--hier Pruefung ob Blatt vorhanden Worksheets("Vorlage").Copy after:=Worksheets(Worksheets.Count) ActiveSheet.Name = Target Else MsgBox "Blattname schon vorhanden", vbInformation End If End If End Sub

Sub Blaetter_erstellen() Dim wksKop As Worksheet Dim wksZiel As Worksheet Dim i As Long Set wksKop = Worksheets("Tabelle1") '--Blattname anpassen v. hier wird kopiert Set wksZiel = Worksheets("Tabelle2") '--Blattname anpassen n. hier wird eingefuegt wksZiel.Columns(2).Clear wksKop.Range("A1:Z1").Copy wksZiel.Range("B1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, _ Transpose:=True For i = 1 To wksZiel.Cells(Rows.Count, 2).End(xlUp).Row If wksZiel.Cells(i, 2) "" Then If IsError(Evaluate(wksZiel.Cells(i, 2) & "!A1")) Then '--hier Pruefung ob Blatt _ vorhanden Worksheets("Vorlage").Copy after:=Worksheets(Worksheets.Count) ActiveSheet.Name = wksZiel.Cells(i, 2) Else MsgBox "Blattname schon vorhanden", vbInformation End If End If Next End Sub

Option Explicit Dim Blattname As String Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count > 1 Then Exit Sub '--wenn mehr als eine Zelle ausgewaehlt beenden If Not Intersect(Target, Columns(2)) Is Nothing Then '--wenn SpalteB eine Zelle ausgewaehlt Blattname = Target '--uebergabe an Variable End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub '--wenn mehr als eine Zelle ausgewaehlt beenden If Blattname = "" Then Exit Sub '--wenn Variable leer beenden If Not Intersect(Target, Columns(2)) Is Nothing Then '--gilt fuer gesammte SpalteB Worksheets(Blattname).Name = Target '--umbenennen Blattname = "" '--Variable leeren End If End Sub

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread