Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

mehrere Blätter in andere Mappe kopieren

mehrere Blätter in andere Mappe kopieren
27.02.2009 14:29:50
Jakob
Hallo,
mit den unten angehängten Code kopiere ich das aktuelle Blatt in eine seperate Mappe. Den Code würde ich jetzt gerne so erweitern, daß mehrere Blätter auf einmal in die gleiche Mappe kopiert werden.
Wie müßte der Code aussehen der das bewerkstellig?
Ich Danke Euch schon mal.
Gruß,
Jakob

Sub TabellenblattKopieren()
Dim strPfad As String, strName As String
With Sheets("Eingabemaske")
strPfad = .Range("A54")
strName = .Range("Lieferung") & " " ' & ".xls"
End With
If Right(strPfad, 1)  "\" Then strPfad = strPfad & "\"
ActiveSheet.Copy
ActiveSheet.Unprotect
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Shapes.Range(Array("Button 1", "Button 2", "Button 3")).Select
Application.CutCopyMode = False
Selection.Delete
Call DeleteAllNames
ActiveWorkbook.SaveAs strPfad & strName & ActiveSheet.Name & ".xls"
Dim Mldg$
End Sub


4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: mehrere Blätter in andere Mappe kopieren
27.02.2009 14:57:40
Josef
Hallo Jakob,
probier mal. Die Namen der Tabellen musst du natürlich anpassen.
Sub TabellenblattKopieren()
  Dim strPfad As String, strName As String
  Dim objWb As Workbook, objWs As Worksheet
  
  With Sheets("Eingabemaske")
    strPfad = .Range("A54")
    strName = .Range("Lieferung") & " " ' & ".xls"
  End With
  
  If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
  
  ThisWorkbook.Sheets(Array("Tabelle1", "Tabelle2")).Copy
  Set objWb = ActiveWorkbook
  With objWb
    For Each objWs In .Worksheets
      objWs.Unprotect
      objWs.UsedRange = objWs.UsedRange.Value
      objWs.Shapes.Range(Array("Button 1", "Button 2", "Button 3")).Delete
    Next
    Call DeleteAllNames
    .SaveAs strPfad & strName & .Sheets(1).Name & ".xls"
  End With
  
End Sub

Gruß Sepp

Anzeige
AW: mehrere Blätter in andere Mappe kopieren
27.02.2009 17:22:01
Jakob
Hallo Sepp,
Dein Vorschlag funktioniert prima. Eine Sache vergaß ich zu erwähnen. Die Tabellenblätter beginnen alle mit den Namen "PK_". Läßt sich das im Code einarbeiten, sodaß wenn in Zukunft weitere Blätter dazukommen diese nicht noch extra im Code geändert werden müssen.
Danke.
Gruß,
Jakob
AW: mehrere Blätter in andere Mappe kopieren
27.02.2009 18:03:56
Josef
Hallo Jakob,
kein Problem.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub TabellenblattKopieren()
  Dim strPfad As String, strName As String, strSheets() As String
  Dim objWb As Workbook, objWs As Worksheet
  Dim lngI As Long
  
  With Sheets("Eingabemaske")
    strPfad = .Range("A54")
    strName = .Range("Lieferung") & " " ' & ".xls"
  End With
  
  If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
  
  For Each objWs In ThisWorkbook.Worksheets
    If objWs.Name Like "PK_?" Then
      Redim Preserve strSheets(lngI)
      strSheets(lngI) = objWs.Name
      lngI = lngI + 1
    End If
  Next
  
  If lngI > 0 Then
    ThisWorkbook.Sheets(strSheets).Copy
    Set objWb = ActiveWorkbook
    
    With objWb
      For Each objWs In .Worksheets
        objWs.Unprotect
        objWs.UsedRange = objWs.UsedRange.Value
        objWs.Shapes.Range(Array("Button 1", "Button 2", "Button 3")).Delete
      Next
      Call DeleteAllNames
      .SaveAs strPfad & strName & .Sheets(1).Name & ".xls"
    End With
  End If
End Sub

Gruß Sepp

Anzeige
AW: mehrere Blätter in andere Mappe kopieren
02.03.2009 11:38:18
Jakob
Hallo Sepp,
hat perfect funktioniert.
Vielen Dank.
Gruß,
Jakob

309 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige