Tabellen anlegen nach Zellbereich

Hallo Exelfreunde!
Ich habe ein Problem.
Ich möchte mit einem Makro neue Blätter gemäß der Einträge der Zellen A6 bis A200 des ersten Blattes anlegen. Also für jeden Eintrag ein Blatt mit dem Eintrag als Blattnamen. Desweiteren sollten sich die Einträge in Blatt 1 in ein Link zum jeweiligen Blatt ändern. Super wäre es, wenn auf jedem Blatt in Zelle A1 auch ein Link zurück zum Ursprung wäre.
Folgende Parameter müssten beachtet werden:
1. leere Zellen im Bereich A6:A200 des ersten Blattes sollten übersprungen werden
2. die Namen der entstehenden Blätter müssen bei 30 Zeichen abgeschnitten werden (manche Einträge im ersten Blatt sind nämlich länger)
3. nicht erlaubte Sonderzeichen in den Einträgen des ersten Blattes sollen im jeweiligen Tabellennamen weggelassen werden
4. das Makro sollte erkennen ob Blätter schon angelegt sind und diese nicht überschreiben (Aktualisierungsmöglichkeit)
Ich habe einige ähnliche Beispiele hier gefunden. Leider habe ich keine Ahnung von VB und kann diese nicht nach meine Wünschen modifizieren.
Vieleicht kann mir jemand helfen!!
Danke im vorraus!
mfg, Andreas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub anlegen() Dim rng As Range, C As Range, newWs As Worksheet, str As String, Ws As Worksheet, B As Boolean Set rng = Range("A6:A200").SpecialCells(xlCellTypeConstants) For Each C In rng str = Bereinigen(Trim(Left(C.Text, 30))) For Each Ws In ThisWorkbook.Worksheets If Ws.Name = str Then MsgBox "Das Blatt " & str & " ist bereits existent,", 64, "Hinweis..." B = True Exit For End If Next Ws If B = False Then Set newWs = Worksheets.Add newWs.Name = Bereinigen(Trim(Left(C.Text, 30))) End If Set newWs = Nothing B = False Next C End Sub

Function Bereinigen(s As String) As String With Application ': \ / ? * [ ] Bereinigen = .Substitute(.Substitute(.Substitute(.Substitute(.Substitute(.Substitute(.Substitute(s, ":", ""), "\", ""), "/", ""), "?", ""), "*", ""), "[", ""), "]", "") End With End Function

Sub anlegen() Dim rng As Range, C As Range, newWs As Worksheet, str As String, Ws As Worksheet, B As Boolean Dim startWs As Worksheet Set startWs = Worksheets("Tabelle1") 'Hier stehen deine Blattnamen - ggfls. anpassen Set rng = startWs.Range("A6:A200").SpecialCells(xlCellTypeConstants) Application.ScreenUpdating = False For Each C In rng str = Bereinigen(Trim(Left(C.Text, 30))) If str = "" Then B = True 'Falls nur 1 Leerzeichen in der Zelle stand For Each Ws In ThisWorkbook.Worksheets If Ws.Name = str Then MsgBox "Das Blatt " & str & " ist bereits existent.", 64, "Hinweis..." B = True Exit For End If Next Ws If B = False Then Set newWs = Worksheets.Add newWs.Name = str End If Set newWs = Nothing B = False Next C startWs.Activate Application.ScreenUpdating = True End Sub

Hi Andreas,
eine Möglichkeit - alles in ein allgemeines Modul:
Option Explicit


Sub anlegen()
Dim rng As Range, C As Range
Dim newWs As Worksheet, Ws As Worksheet, startWs As Worksheet
Dim B As Boolean
Set startWs = Worksheets("Tabelle1") 'Hier stehen deine Blattnamen - ggfls. anpassen
Set rng = startWs.Range("A6:A200")
Application.ScreenUpdating = False
Call entruempeln(rng, startWs)
Set rng = rng.SpecialCells(2)
For Each C In rng
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name = C.Text Then
MsgBox "Das Blatt " & C.Text & " ist bereits existent.", 64, "Hinweis..."
B = True
Exit For
End If
Next Ws
If B = False Then
Set newWs = Worksheets.Add
newWs.Name = C.Text
End If
Set newWs = Nothing
B = False
Next C
startWs.Activate
Application.ScreenUpdating = True
End Sub


Sub entruempeln(rng As Range, Ws As Worksheet)
Dim C As Range, arr(), i As Long, j As Long
rng.SpecialCells(4).EntireRow.Delete
Set rng = rng.SpecialCells(2)
ReDim arr(rng.Count)
With Application
For Each C In rng
C = .Trim(Bereinigen(Left(C.Text, 30)))
Next C
For Each C In rng
If .CountIf(Ws.Range(rng(1).Address & ":" & C.Address), C.Text) > 1 Then
arr(i) = C.Text & .CountIf(Ws.Range(rng(1).Address & ":" & C.Address), C.Text)
Else
arr(i) = C.Text
End If
i = i + 1
Next C
End With
For j = 0 To i
rng(j + 1).Value = arr(j)
Next j
End Sub


Function Bereinigen(s As String) As String
With Application ': \ / ? * [ ]
Bereinigen = .Substitute(.Substitute(.Substitute(.Substitute(.Substitute(.Substitute(.Substitute(s, ":", ""), "\", ""), "/", ""), "?", ""), "*", ""), "[", ""), "]", "")
End With
End Function

Aufgerufen wird die Prozedur "anlegen()".
Grüße Boris

Beliebteste Forumthreads (12 Monate)

Tabellen anlegen nach Zellbereich

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread