Blätter nach Eintrag in Bereich anlegen

Hallo Forumsteilnehmer,
ich benötige mal wieder die Hilfe aller VBA-Kundigen.
Ich will mit einem Makro folgendes erreichen:
Das Makro soll zunächst prüfen, ob in der Arbeitsmappe Tabellen vorhanden sind mit der Tabellenbezeichnung eines Eintrags in der Tabelle "PW" im Bereich A1:A30.
Sind im Bereich A1:A30 Zelleinträge vorhanden, für die eine entsprechende Tabelle in der Arbeitsmappe(noch) nicht existiert, soll die Tabelle2 der Arbeitsmappe jeweils kopiert und unter dem entsprechenden Tabellennamen (Zelleintrag im Bereich A1:A30) in die Mappe eingefügt werden.
Hinweis: In den Zellen A1:A30 steht jeweils eine Formel, die entweder einen Textwert oder den Wert "" liefert.
Beispiel:
Im vorliegenden Fall sind in der Tabelle "PW" im Bereich A1:A30 folgende Zellen mit einem Textwert "belegt:
A1 mit fritz
A2 mit schmitz
A3 mit meier
A4 mit werner
Die Zellen A5:A30 der Tabelle "PW" enthalten den Wert "".
Die Arbeitsmappe enthält derzeit die Tabellenblätter "PW", "Tabelle1", "Tabelle2" und "fritz".
Unter diesen Voraussetzungen sollte das Makro die "Tabelle2" kopieren und die Kopie unter den Tabellenbezeichnungen "schmitz", "meier" und "werner" in die Arbeitsmappe einfügen.
Vielen Dank für eure Unterstützung.
Mfg
Fritz

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub PW_Blätter() Dim PWs As Variant, i As Integer Application.ScreenUpdating = False With ThisWorkbook PWs = .Worksheets("PW").Range("A1:A30") For i = 1 To UBound(PWs) If Not IsEmpty(PWs(i, 1)) Then If PWFehlt(PWs(i, 1)) Then .Worksheets("Tabelle2").Copy after:=.Sheets(Sheets.Count) .Worksheets(Sheets.Count).Name = PWs(i, 1) End If End If Next End With Application.ScreenUpdating = False End Sub

Function PWFehlt(ByVal ShName As String) Dim i As Integer With ThisWorkbook For i = .Sheets.Count To 1 Step -1 If .Sheets(i).Name = ShName Then Exit Function Next End With PWFehlt = True End Function

Hallo Fritz,
das sollte es tun.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub anlegenBlaetter()
Dim rng As Range
Dim strNew As String

With Sheets("PW")
    For Each rng In .Range("A1:A30")
        strNew = Trim$(rng.Text)
        If Len(strNew) > 0 Then
            If IsValidSheetName(strNew) Then
                If Not SheetExist(strNew) Then
                    Sheets("Tabelle2").Copy After:=Sheets(Sheets.Count)
                    Sheets(Sheets.Count).Name = strNew
                End If
            End If
        End If
    Next
End With

End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
    If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Private Function IsValidSheetName(ByVal strName As String) As Boolean
Dim objRegExp As Object

Set objRegExp = CreateObject("vbscript.regexp")

With objRegExp
    .Global = True
    .Pattern = "^[^\/\\:\*\?\[\]]{1,31}$"
    .IgnoreCase = True
    IsValidSheetName = .test(strName)
End With

Set objRegExp = Nothing

End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Blätter nach Eintrag in Bereich anlegen

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread