Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1372to1376
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro zum kopieren von Tabellenblätter

Makro zum kopieren von Tabellenblätter
01.08.2014 13:36:59
Tabellenblätter
Hallo zusammen,
meine bisherigen Versuche, ein Makro zu erstellen (mit dem Makrorecorder), waren wenig erfolgreich. Ich benötige ein Makro, um Tabellenblätter anhand von Werten aus einer Spalte zu erstellen. Könnt Ihr mir ein Makro erstellen mit den folgenden Bedingungen:
1. Ist Zelle B4 gefüllt?
1.a wenn ja: Ist bereits ein Tabellenblatt mit Name aus B4 vorhanden?
1.a.I wenn ja: Gehe zu 1. mit Zeile +1
1.a.II wenn nein: Kopiere Tabellenblatt Dummy (ans Ende), Tabellenblattname ist Wert aus B4; Gehe zu 1. mit Zeile +1
1.b wenn nein: Gehe zu 1. mit Zeile +1
Die Abfrage soll bis Zeile 63 durchlaufen. Hier seht Ihr meine Beispieldatei: https://www.herber.de/bbs/user/91827.xlsm
Wie Ihr erkennt gibt es bereits das ein oder andere Tabellenblatt, ebenso können zwischen den einzelnen gefüllten Feldern Lücken sein. Tabellenblatt Dummy ist ausgeblendet und schreibgeschützt.
Durchschnittlich werden voraussichtlich 20 Werte in der Datei gefüllt sein, allerdings können bis zu 60 Werte erlaubt sein. Ist das von mir beschriebene Makro noch performant? Oder wird es sehr lange rechnen, weil es 60 Zeilen durchkämmt? Wenn letzteres der Fall ist müsste ich auf die Leerzeilen verzichten, sodass das Makro stoppt, sobald die erste Leerzeile erreicht ist. Eine Prüfung auf ein bereits vorhandenes Tabellenblatt ist jedoch wichtig.
Vielen Dank im Voraus für Eure Mühe.
Grüße
Martin

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

Betreff
Datum
Anwender
Anzeige
AW: Makro zum kopieren von Tabellenblätter
01.08.2014 14:18:43
Tabellenblätter
Hallo Martin,
nachfolgend ein entsprechendes Makro.
Laufzeit je nach Rechnerleistung 1 bis 2 Sekunden. Evtl. etwas länger, wenn dein Dummyblatt viele Formel enthalten sollte.
Gruß
Franz
Sub Tabellen_Erstellen()
Dim strName As String, Zelle As Range, strVorher As String, StatusCalc As Long
Dim wks As Worksheet
On Error Resume Next
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With ActiveWorkbook
.Worksheets("Dummy").Visible = xlSheetVisible
For Each Zelle In ActiveWorkbook.Worksheets("Tabelle1").Range("B4:B63")
If Zelle.Text  "" Then
strName = Zelle.Text
Set wks = .Worksheets(strName)
If wks Is Nothing Then
.Worksheets("Dummy").Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = strName
End If
Set wks = Nothing
End If
Next
.Worksheets("Dummy").Visible = xlSheetHidden
End With
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End Sub

Anzeige
AW: Makro zum kopieren von Tabellenblätter
01.08.2014 16:40:58
Tabellenblätter
Danke Franz, dass ging ja sehr schnell!
Das Makro funktioniert einwandfrei bei mir. Zwei Sachen sind mir noch aufgefallen: Zum Einen möchte ich am Ende das Tabellenblatt 1 markiert haben. Das bekomme ich selbst hin mit einem Selection.Copy.
Des weiteren hätte ich noch gerne eine Abschlussmeldung á la "Es wurden XY Mannschaften hinzugefügt"
Ist das auch noch möglich?
Danke und Grüße
Martin

AW: Makro zum kopieren von Tabellenblätter
02.08.2014 14:50:19
Tabellenblätter
Hallo Martin,
kein großes Problem.
Gruß
Franz
Sub Tabellen_Erstellen()
Dim strName As String, Zelle As Range, strVorher As String, StatusCalc As Long
Dim intCount As Integer
Dim wks As Worksheet
On Error Resume Next
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
With ActiveWorkbook
.Worksheets("Dummy").Visible = xlSheetVisible
For Each Zelle In ActiveWorkbook.Worksheets("Tabelle1").Range("B4:B63")
If Zelle.Text  "" Then
strName = Zelle.Text
Set wks = .Worksheets(strName)
If wks Is Nothing Then
.Worksheets("Dummy").Copy after:=.Sheets(.Sheets.Count)
ActiveSheet.Name = strName
intCount = intCount + 1
End If
Set wks = Nothing
End If
Next
.Worksheets("Dummy").Visible = xlSheetHidden
.Worksheets("Tabelle1").Select
End With
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
MsgBox "Es wurden Tabellenblätter für " & intCount & " Mannschaften hinzugefügt", _
vbInformation + vbOKOnly, "Tabellenblätter anlegen"
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige