Tabellenblätter mehrfach kopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Tabellenblätter mehrfach kopieren
von: Stefan
Geschrieben am: 27.09.2015 22:05:48

Hallo ich habe folgendes Problem:
Ich habe die Tabellenblätter "Vorlage" und eine "Mitarbeiterliste"
Jetzt bräuchte ich das sich die Vorlage für jeden Mitarbeiter kopiert und nach ihm benennt.
Das heißt ich habe das Tabellenblatt das sich "Vorlage" nennt, und er soll per vba das Tabellenblatt "Mitarbeiterliste" heranziehen und die Namen der Mitarbeiter in dem Bereich (A1:A29) nehmen und mir die Vorlage kopieren und automatisch mit den Namen benennen.
In der Zelle A1 steht der Name Huber
A2 Mayer
A3 Müller
A4 Schmid
usw.
Das heißt am Ende sollte ich 29 Tabellenblätter haben, und jedes lautet dann am Namen des Mitarbeiters.
Wie macht man sowas am besten, bzw. wie muss der Code dazu aussehen? Ich hoffe ich hab es verständlich geschrieben.

Bild

Betrifft: 1000x gefragt ...
von: Rudi Maintaire
Geschrieben am: 27.09.2015 22:19:18
Hallo,
... und gelöst.
Recherche Tabellenblätter erstellen nach Liste oder so ähnlich.
Gruß
Rudi

Bild

Betrifft: AW: Tabellenblätter mehrfach kopieren
von: Sepp
Geschrieben am: 27.09.2015 22:21:52
Hallo Stefan,

' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub makeSheets()
Dim objTemplate As Worksheet
Dim rng As Range

On Error GoTo ErrExit

Static CalculationMode As Long

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

Set objTemplate = Sheets("Vorlage")

For Each rng In Sheets("Mitarbeiterliste").Range("A1:A29")
  If Len(Trim$(rng.Text)) Then
    objTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
      .Name = Trim$(rng.Text)
      .Visible = xlSheetVisible
    End With
  End If
Next

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'makeSheets'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - makeSheets"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub

Gruß Sepp


Bild

Betrifft: AW: Tabellenblätter mehrfach kopieren
von: Werner
Geschrieben am: 28.09.2015 02:13:04
Hallo Stefan,
hier der Code vom Forumsbetreiber selbst:

Sub Blätter_anlegen_bennenen()
   Dim wks As Worksheet
   Dim iRow As Integer
   Set wks = ActiveSheet
   iRow = 1
   Do Until IsEmpty(wks.Cells(iRow, 1))
      Worksheets.Add after:=Worksheets(Worksheets.Count)
      ActiveSheet.Name = wks.Cells(iRow, 1).Value
      iRow = iRow + 1
   Loop
   Worksheets(1).Select
End Sub
Gruß Werner

Bild

Betrifft: .Add kopiert aber nicht die Vorlage! ___ kwT ;-)
von: Matthias L
Geschrieben am: 28.09.2015 04:49:04


Bild

Betrifft: AW: .Add kopiert aber nicht die Vorlage! ___ kwT ;-)
von: Werner
Geschrieben am: 28.09.2015 05:12:11
Hallo Matthias,
stimmt natürlich, liegt wohl an der Zeit. Was meinst du dazu? Das hätte Stefan aber vielleicht auch selbst hin bekommen.

Sub Blätter_anlegen_bennenen()
    Dim wks As Worksheet
    Dim iRow As Integer
    Set wks = Worksheets("Mitarbeiterliste")
    iRow = 1
    Do Until IsEmpty(wks.Cells(iRow, 1))
       Worksheets("Vorlage").Copy after:=Worksheets(Worksheets.Count)
       ActiveSheet.Name = wks.Cells(iRow, 1).Value
       iRow = iRow + 1
    Loop
    Worksheets(1).Select
 End Sub
Gruß Werner

Bild

Betrifft: auf jeden Fall besser ;-)
von: Matthias L
Geschrieben am: 28.09.2015 05:31:48
Hallo
Ist ja schon mal besser als vorher ;-)
Nur darf man den Code eben nicht ein 2.Mal ausführen.
Dann gibts einen Crash.
Beim Bsp. von Sepp wird das zwar mit einer Fehlermeldung abgefangen,
aber auch dort wird dann Vorlage(2), Vorlage(3) ... erstellt.
Ist zwar kein Fehler(war nicht gefordert/gewünscht), sollte aber mE über eine Abfrage
ob das entsprechende Blatt bereits existiert auch abgefangen werden.
Nur so als Vorschlag.
Gruß Matthias

Bild

Betrifft: AW: auf jeden Fall besser ;-)
von: Werner
Geschrieben am: 28.09.2015 13:16:17
Hallo Matthias,
ist mir, nachdem der Code online war auch bewusst geworden. Ist wohl doch nicht so gut das im Nachtdienst um diese Zeit noch zu machen, wobei ich von VBA selbst nicht so viel Ahnung habe. ;-)
Gruß Werner

Bild

Betrifft: AW: Tabellenblätter mehrfach kopieren
von: Reiter
Geschrieben am: 28.09.2015 13:41:18
Also mal vielen Dank für die Antworten es funktioniert super.
Jetzt hätte ich noch eine Frage. Kann man das auch so machen das er in die Zelle A1  automatisch den jeweiligen Mitarbeiternamen schreibt?
Und das wenn ich die Liste um einen Mitarbeiter erweitere er mir nur die Vorlage neu anlegt für den neuen Mitarbeiter und die anderen Mitarbeiter wo es schon ein Tabellenblatt gibt ignoriert?

Bild

Betrifft: AW: Tabellenblätter mehrfach kopieren
von: Sepp
Geschrieben am: 28.09.2015 18:43:14
Hallo Stefan,

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub makeSheets()
Dim objTemplate As Worksheet
Dim rng As Range

On Error GoTo ErrExit

Static CalculationMode As Long

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

Set objTemplate = Sheets("Vorlage")

For Each rng In Sheets("Mitarbeiterliste").Range("A1:A29")
  If Len(Trim$(rng.Text)) Then
    If Not SheetExist(Trim$(rng.Text)) Then
      objTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
      With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        .Name = Trim$(rng.Text)
        .Visible = xlSheetVisible
        .Range("A1") = Trim$(rng.Text)
      End With
    End If
  End If
Next

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'makeSheets'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - makeSheets"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
  If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Gruß Sepp


Bild

Betrifft: Janice Keihanaikukauakahihuliheekahaunaele
von: Matthias L
Geschrieben am: 29.09.2015 07:02:35
Hi Sepp
Hauptache es heißt kein Mitarbeiter
Janice Keihanaikukauakahihuliheekahaunaele
oder so ;-)
Mitarbeiterliste

 AB
1Mitarbeiter112
2Janice Keihanaikukauakahihuliheekahaunaele42
3Mitarbeiter312
4Mitarbeiter412


Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Gibts wirklich, habs gerade gefunden.
http://www.spiegel.de/panorama/leute/janice-keihanaikukauakahihuliheekahaunaele-name-zu-lang-fuer-ausweis-a-922042.html
Nur n Späßle am Rande ;-)
Kann aber u.U. auch vorkommen.
Schlage vor das mit abzufragen:
'''
      With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        .Name = Left(Trim$(rng.Text), 31)
'''

und in der Function SheetExist
'''
For Each wks In Wb.Sheets
If Left(LCase(wks.Name), 31) = Left(LCase(sheetName), 31) Then SheetExist = True: Exit Function
Next
'''
Gruß Matthias

Bild

Betrifft: dann aber auch die Gültigkeit des namens prüfen
von: Sepp
Geschrieben am: 29.09.2015 21:17:05
Hallo Matthias,

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub makeSheets()
Dim objTemplate As Worksheet
Dim rng As Range, strName As String

On Error GoTo ErrExit

Static CalculationMode As Long

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  CalculationMode = .Calculation
  .Calculation = xlManual
  .DisplayAlerts = False
End With

Set objTemplate = Sheets("Vorlage")

For Each rng In Sheets("Mitarbeiterliste").Range("A1:A29")
  If Len(Trim$(rng.Text)) Then
    strName = Left(Trim$(rng.Text), 31)
    If IsValidSheetName(strName) Then
      If Not SheetExist(strName) Then
        objTemplate.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
          .Name = strName
          .Visible = xlSheetVisible
          .Range("A1") = strName
        End With
      End If
    End If
  End If
Next

ErrExit:

With Err
  If .Number <> 0 Then
    MsgBox "Fehler in Prozedur:" & vbTab & "'makeSheets'" & vbLf & String(60, "_") & _
      vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
      "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
      .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
      "VBA - Fehler in Prozedur - makeSheets"
    .Clear
  End If
End With

On Error GoTo 0

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .Calculation = CalculationMode
  .DisplayAlerts = True
  .StatusBar = False
End With

End Sub

Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
Dim wks As Object
On Error GoTo ERRORHANDLER
If Wb Is Nothing Then Set Wb = ThisWorkbook
For Each wks In Wb.Sheets
  If LCase(wks.Name) = LCase(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


Bild

Betrifft: AW: dann aber auch die Gültigkeit des namens prüfen
von: Stefan
Geschrieben am: 29.09.2015 22:09:41
Also mal vielen Dank für die ganzen Antworten und die Hilfe!
Es funktioniert echt super, mein einziges Problem ist das bei meiner Vorlage das Datenblatt geschützt ist, und das hätte ich auch gern dann noch bei den anderen die sich dann erstellen.
Kann man da noch was im Makro ändern bzw. anpassen? Wäre super wenn das auch noch funktionieren würde.

Bild

Betrifft: AW: dann aber auch die Gültigkeit des namens prüfen
von: Sepp
Geschrieben am: 29.09.2015 22:14:07
Hallo Stefan,
passe diesn Teil an.

With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
  .Unprotect "passwort"
  .Name = strName
  .Visible = xlSheetVisible
  .Range("A1") = strName
  .Protect "passwort"
End With

Gruß Sepp


Bild

Betrifft: AW: dann aber auch die Gültigkeit des namens prüfen
von: Stefan
Geschrieben am: 29.09.2015 22:19:19
Hab es grad geändert, funktioniert jetzt absolut perfekt.
Danke Sepp!

 Bild

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