Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Makro zum kopieren von Tabellenblätter

Betrifft: Makro zum kopieren von Tabellenblätter von: Martin
Geschrieben am: 01.08.2014 13:36:59

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

  

Betrifft: AW: Makro zum kopieren von Tabellenblätter von: fcs
Geschrieben am: 01.08.2014 14:18:43

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



  

Betrifft: AW: Makro zum kopieren von Tabellenblätter von: Martin
Geschrieben am: 01.08.2014 16:40:58

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


  

Betrifft: AW: Makro zum kopieren von Tabellenblätter von: fcs
Geschrieben am: 02.08.2014 14:50:19

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



 

Beiträge aus den Excel-Beispielen zum Thema "Makro zum kopieren von Tabellenblätter"