automat. Arbeitsblatt anlegen u. benennen

Bild

Betrifft: automat. Arbeitsblatt anlegen u. benennen
von: Wolfango
Geschrieben am: 09.06.2015 16:23:46

Hallo Experten,
vor etwa 2 Wochen habe ich Dank dieses genialen Forums untenstehenden VBA-Code erhalten.
Das Makro funktioniert auch einwandfrei!
(Großes DANKE nochmal an Sepp!!)
Nun brauche ich eine kleine Änderung bzw. Erweiterung:
In der vorliegenden Form erstellt das Makro bei mehreren Aufrufen mehrere Arbeitsblätter mit den Bezeichnungen "Formular 01", "Formular 02", "Formular 03", usw.
Nun möchte ich aber keine fortlaufende Nummerierung, sondern das anstelle von 01, 02, 03 usw. dort der Inhalt der Zelle I2 erscheint!
Also angenommen in Zelle I2 steht die Zahl 007, dann soll das erzeugte Arbeitsblatt die Bezeichnung "Formular 007" erhalten.
Wie muss der Code geändert werden um dieses Ergebnis zu erhalten?
Danke vorab!
Gruß, Wo


Option Explicit
Sub formular()
  Dim lngI As Long
  Dim objSh As Worksheet, objActive As Worksheet
  Set objActive = ActiveSheet
  
  On Error GoTo ErrExit
  
  Application.ScreenUpdating = False
  
  Do While lngI < 99
    lngI = lngI + 1
    If Not SheetExist("Formular " & Format(lngI, "00")) Then
      Set objSh = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets. _
Count))
      objSh.Name = "Formular " & Format(lngI, "00")
      objActive.Range("A1:K20").Copy
      With objSh.Range("A1")
        .PasteSpecial -4163
        .PasteSpecial -4122
        .PasteSpecial xlPasteColumnWidths
        .Select
      End With
      objActive.Activate
      Exit Do
    End If
  Loop
  
  ErrExit:
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
  
  Set objActive = Nothing
  Set objSh = 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 LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function

Bild

Betrifft: AW: automat. Arbeitsblatt anlegen u. benennen
von: UweD
Geschrieben am: 09.06.2015 16:34:22
Ungeprüft...

Sub formular()
  Dim lngI As Long
  Dim objSh As Worksheet, objActive As Worksheet
  Set objActive = ActiveSheet
  
  On Error GoTo ErrExit
  
  Application.ScreenUpdating = False
  
  Do While lngI < 99
    lngI = lngI + 1
    If Not SheetExist("Formular " & objActive.Range("I2")) Then
      Set objSh = ThisWorkbook.Worksheets.Add(after:= _
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
      objSh.Name = "Formular " & objActive.Range("I2")
      objActive.Range("A1:K20").Copy
      With objSh.Range("A1")
        .PasteSpecial -4163
        .PasteSpecial -4122
        .PasteSpecial xlPasteColumnWidths
        .Select
      End With
      objActive.Activate
      Exit Do
    End If
  Loop
  
ErrExit:
  With Application
    .CutCopyMode = False
    .ScreenUpdating = True
  End With
  
  Set objActive = Nothing
  Set objSh = Nothing
End Sub
Gruß UweD

Bild

Betrifft: AW: automat. Arbeitsblatt anlegen u. benennen
von: Wolfango
Geschrieben am: 09.06.2015 17:01:48
Super! Funktioniert!
Vielen Dank!
Gruß, Wo

 Bild

Beiträge aus den Excel-Beispielen zum Thema "automat. Arbeitsblatt anlegen u. benennen"