Formatierung inkl Seitenumbruch behalten

Sub Monat_anlegen() Dim rngMuster As Range, zz As Long, ss As Long Set rngMuster = Sheets("Vorlage").Columns("A:P") 'Blätter nach "Vorlage" erstellen With Sheets("Datum") 'alle Blätter nach _ _ _ _ Blatt "Datum" einfügen For zz = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row For ss = 1 To Sheets.Count If Sheets(ss).Name = CStr(.Cells(zz, 1)) Then MsgBox "Blatt '" & .Cells(zz, 1) & "' bereits vorhanden.", vbInformation Exit For End If Next ss If ss > Sheets.Count Then Worksheets.Add After:=Sheets(Sheets.Count) rngMuster.Copy Cells(1, 1) Cells(1, 6) = .Cells(zz, 1) ActiveSheet.Name = CStr(Cells(1, 6)) End If Next zz End With ThisWorkbook.Worksheets("Daten").Move After:=ThisWorkbook.Sheets(Sheets.Count) 'Blatt "Daten" _ _ _ _ ans Ende stellen Sheets("Datum").Select 'zurückspringen ins Blatt "Datum" Range("C6").Select End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Monika,
kopiere doch das gesamte Blatt 'Vorlage'.
Modul Modul1

Option Explicit 
 
Sub Monat_anlegen() 
  Dim objWS As Object, lngRow As Long 
      
  On Error GoTo ErrorHandler 
 
  With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
    .Calculation = xlCalculationManual 
  End With 
 
  With Sheets("Datum")                                                      'alle Blätter nach Blatt "Datum" einfügen 
    For lngRow = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row 
      If Not SheetExist(CStr(.Cells(lngRow, 1))) Then 
        Call Sheets("Vorlage").Copy(After:=Sheets(Sheets.Count)) 
        Sheets(Sheets.Count).Cells(1, 6) = .Cells(lngRow, 1) 
        Sheets(Sheets.Count).Name = CStr(Cells(1, 6)) 
      End If 
    Next lngRow 
  End With 
    
  Worksheets("Daten").Move After:=Sheets(Sheets.Count)  'Blatt "Daten" ans Ende stellen 
 
  Application.Goto Sheets("Datum").Range("C6")                            'zurückspringen ins Blatt "Datum" 
   
  Set objWS = Nothing 
 
ErrorHandler: 
 
  With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = xlCalculationAutomatic 
  End With 
 
End Sub 
 
Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook, Optional ByVal byCodeName As Boolean = False) 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 byCodeName Then 
      If LCase(wks.CodeName) = LCase(sheetName) Then SheetExist = True: Exit Function 
    Else 
      If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function 
    End If 
  Next 
ErrorHandler: 
  SheetExist = False 
End Function 

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0

	A	B	C	D	E	F
1	Gruß Sepp
2
3

Beliebteste Forumthreads (12 Monate)

Formatierung inkl Seitenumbruch behalten

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread