Tabellenblätter kopieren mit Stammdatenblatt

Hallo Zusammen,
ich stehe vor einem Problem, welches ich auch durch lange Recherche hier im Forum nicht lösen konnte.
Aber vielleicht hat ja jemand von Euch eine Idee.
Ich habe eine Mappe mit ca 55 Blättern.
Die Blätter möchte ich einzeln in neue Arbeitsmappen kopieren und unter dem jeweiligen Sheetnamen abspeichern. Soweit so gut.
Allerdings befinden sich in der Mappe zwei Blätter ("Help" und "Data") die ebenfalls immer mit den einzelnen Blättern kopiert und abgespeichert werden sollen. In den 53 neuen Mappen sollen sich also jeweils das Blatt "Help", "Data" und eines der 53 einzelnen Blätter befinden.
Mein Code funktioniert leider nicht und ich hoffe auf gute Vorschläge von Euch:


Sub alle_Tab_als_Datei()
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(Array("Help", "Data" ,  i)).Copy
ActiveWorkbook.SaveAs Sheets(i).Name
ActiveWorkbook.Close
Next
End Sub

Vielen lieben Dank!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Josephine,
ungetestet!

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

Option Explicit

Sub alle_Tab_als_Datei()
  Dim objSh As Worksheet
  Dim strPath As String, strExt As String, lngFormat As Long
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
  End With
  
  strPath = ThisWorkbook.Path  'oder C:\Verzeichnis
  
  strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
  
  For Each objSh In ThisWorkbook.Worksheets
    Select Case objSh.Name
      Case "Help", "Data"
      Case Else
        Sheets(Array(objSh.Name, "Help", "Data")).Copy
        If lngFormat = 0 Then
          getFileExtAndFormat ActiveWorkbook, strExt, lngFormat
        End If
        With ActiveWorkbook
          .SaveAs strPath & objSh.Name & strExt, lngFormat
          .Close
        End With
    End Select
  Next
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'alle_Tab_als_Datei'" & 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 Modul - Modul1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
  End With
  
End Sub


Private Function getFileExtAndFormat(ByRef WB As Workbook, ByRef strExt As String, ByRef lngFormat As Long)
  With WB
    If Val(Application.Version) < 12 Then
      strExt = ".xls": lngFormat = -4143
    Else
      Select Case WB.FileFormat
        Case 51: strExt = ".xlsx": lngFormat = 51
        Case 52:
          If .HasVBProject Then
            strExt = ".xlsm": lngFormat = 52
          Else
            strExt = ".xlsx": lngFormat = 51
          End If
        Case 56: strExt = ".xls": lngFormat = 56
        Case Else: strExt = ".xlsb": lngFormat = 50
      End Select
    End If
  End With
End Function

« Gruß Sepp »

Beliebteste Forumthreads (12 Monate)

Tabellenblätter kopieren mit Stammdatenblatt

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

313 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenblätter kopieren mit Stammdatenblatt

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

313 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread