kopieren eines großen Tabellenblatts nicht möglich

Hallo zusammen,
der nette Sepp (Josef Ehrensberger) aus diesem Forum hat mir ein Makro geschrieben, das nach Erfüllung verschiedener Bedingungen mehrere neue Tabellenblätter erzeugt, indem ein "Vorlage-Tabellenblatt" kopiert wird. Das Makro funktioniert tadellos - allerdings nur, wenn das "Vorlage-Tabellenblatt" leer oder (wie ich vermute) sehr klein ist (da sind dann 20 neue Tabellenblätter auf einmal kein Problem). Nun ist das Vorlage-Tabelleblatt im meinem Fall allerdings ziemlich groß (ein Haufen Diagramme sowie eine große und eine kleinere Tabelle) und nach etwa 10 bis 11 neu angelegten Blättern ist Schluss. Ich habe dann mal versucht, diese Vorlage von "Hand" zu vervielfältigen (sowohl über den Befehl kopieren/ verschieben im Kontextmenü, als auch über Strg+C und Strg+V in der rechten oberen Ecke), aber auch da ist nach 10 bis 11 mal Feierabend.
Da das (mehrfache) "auf-einmal-kopieren" meiner Vorlage weder mit dem Makro noch manuell funktioniert, wollte ich mal in die Runde fragen, ob jemand eine Idee hat, woran das liegen kann.
Im voraus schon vielen Dank für alle Meldungen, Tipps und Anregungen!
Liebe Grüsse
Bibabutzel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo
ich habe mir jetzt eine Notlösung überlegt: Ich erzeuge mir einen (übergroßen) "Vorrat" an den benötigten Tabellenblättern, blende sie aus und benenne sie aufsteigend nach Zahlen (also 1, 2, 3, etc.).
Ist es möglich, das Makro von Sepp (siehe unten) so umzuschreiben, dass nach der Prüfung nicht ein neues Tabellenblatt erzeugt wird, sondern dass das (nun schon bestehende) Tabellenblatt mit der kleinsten Zahl einfach nur umbenannt wird (und den Namen bekommt, der in Blatt2 nicht vorhanden war)?

Private Sub Worksheet_Change(ByVal Target As Range)
Dim objSh As Worksheet, rng As Range
Dim vntRet As Variant
On Error GoTo ErrExit
If Target.Column = 1 Then
For Each rng In Intersect(Target, Columns(1))
If rng  "" Then
Select Case rng.Row
Case 10 To 34, 40 To 64, 70 To 94 'hier die Blöcke (Zeilen) angeben!
vntRet = Application.Match(rng.Value, Sheets("Blatt2").Range("A20:A" & _
Application.Max(20, Sheets("Blatt2").Cells(Rows.Count, 1).End(xlUp).Row)), 0)
If Not IsNumeric(vntRet) Then
Application.ScreenUpdating = False
Sheets("Blatt2").Range("A" & Application.Max(20, Sheets("Blatt2").Cells(Rows. _
Count, _
1).End(xlUp).Row + 1)) = rng.Value
If Not SheetExist(rng.Value) Then
Sheets("Blatt3").Copy After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = rng.Value
Me.Activate
End If
End If
Case Else
End Select
End If
Next
End If
ErrExit:
Application.ScreenUpdating = True
Set objSh = Nothing
Set rng = Nothing
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 wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Danke für Eure Hilfe!

Private Sub Worksheet_Change(ByVal Target As Range) Dim objSh As Worksheet, rng As Range, strMin As String Dim vntRet As Variant On Error GoTo ErrExit If Target.Column = 1 Then For Each rng In Intersect(Target, Columns(1)) If rng "" Then Select Case rng.Row Case 10 To 34, 40 To 64, 70 To 94 'hier die Blöcke (Zeilen) angeben! vntRet = Application.Match(rng.Value, Sheets("Blatt2").Range("A20:A" & _ Application.Max(20, Sheets("Blatt2").Cells(Rows.Count, 1).End(xlUp).Row)), 0) If Not IsNumeric(vntRet) Then Application.ScreenUpdating = False Sheets("Blatt2").Range("A" & Application.Max(20, _ Sheets("Blatt2").Cells(Rows.Count, 1).End(xlUp).Row + 1)) = rng.Value If Not SheetExist(rng.Value) Then strMin = SheetMinNummer If strMin = "0" Then MsgBox "Keine Blätter mehr zum Umbenennen vorhanden!" Exit Sub Else Sheets(strMin).Name = rng.Value Me.Activate ' ThisWorkbook.Save End If End If End If Case Else End Select End If Next End If ErrExit: Application.ScreenUpdating = True Set objSh = Nothing Set rng = Nothing 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 wks.Name = sheetName Then SheetExist = True: Exit Function Next ERRORHANDLER: SheetExist = False End Function Function SheetMinNummer() As String Dim wks As Worksheet, MinNummer As Long MinNummer = 0 For Each wks In ThisWorkbook.Worksheets If Val(wks.Name) > 0 Then If MinNummer = 0 Then MinNummer = Val(wks.Name) ElseIf Val(wks.Name)

Beliebteste Forumthreads (12 Monate)

kopieren eines großen Tabellenblatts nicht möglich

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

339 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

kopieren eines großen Tabellenblatts nicht möglich

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

339 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread