Tabellenblätter mehrfach kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

' ********************************************************************** ' 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

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

Beliebteste Forumthreads (12 Monate)

	A	B
1	Mitarbeiter1	12
2	Janice Keihanaikukauakahihuliheekahaunaele	42
3	Mitarbeiter3	12
4	Mitarbeiter4	12

Tabellenblätter mehrfach kopieren

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

30 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenblätter mehrfach kopieren

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

30 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread