Excel: Arbeitsblätter kopieren in neue Tabelle

Dieses Thema Excel: Arbeitsblätter kopieren in neue Tabelle im Forum "Microsoft Office Suite" wurde erstellt von falcon30, 6. Juni 2005.

Thema: Excel: Arbeitsblätter kopieren in neue Tabelle Hallo Zusammen, ich habe mehrere Excel-Dateien die mehrere Arbeitsblätter haben. Ich würde gerne die...

  1. Hallo Zusammen,

    ich habe mehrere Excel-Dateien die mehrere Arbeitsblätter haben.
    Ich würde gerne die Arbeitsblätter die mit einem P anfangen in eine neue Tabelle kopieren wollen.

    Grüße
    falcon30
     
  2. Ola,

    alle Blätter mit P markieren (anklicke mit gehaltener STRG-Taste) dann rechte Maustaste auf markeirte Dateien Häkchen bei Kopieren und dann neue Mappe als Zeil anwählen. Bei den anderen Mappen gibst du dann diese neue Mappe als Ziel für die kopierten an.
     
  3. Hallo PCDjoe ,

    da ich die Aktion mehrere Male anstarten möchte (z.B. 1x die Woche), wäre es toll wenn ich ein Makro hätte, was ich z.B. per Button starten könnte.

    Grüße
    falcon30
     
  4. Hallo falcon30,

    der nachfolgend Makro sollte deine Belage erfüllen.

    In der Function MeineArbeitsmappen_NamenFestlegen mußt du nur deine Dateien bekanntgeben, indem du jeweils einen Eintrag für Pfad und Dateiname einfügst. Die beiden Test-Einträge solltest Du mit den Angaben zu den ersten 2 Dateien modifizieren.

    Gruß Matjes :)
    Code:
    Option Explicit
    
    Type my_Arbeitsmappen_structure
      s_Pfad As String
      s_Name As String
      s_FullName As String
      b_geoeffnet As Boolean
      b_NameMehrfach As Boolean
    End Type
    '***********************************************************
    Sub BlaetterMitPBeginnendInNeueArbeitsmappe()
    '*** Aus den definierten Dateien werden die
    '*** Blätter, deren Name mit p/P beginnt,
    '*** in eine neue Arbeitsmappe kopiert
    '***
    '*** ACHTUNG !!!
    '*** sind auf den kopierten Blättern Zellen,
    '*** deren Inhalt mehr als 255 Zeichen beträgt,
    '*** wird der Inhalt auf 255 Zeichen beschnitten
    '*** ACHTUNG !!!
    
    
     ->Feld meine Arbeitsmappen
      Dim f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long
      
      Dim wbz As Workbook, wsz_leer As Worksheet, x As Long
      
     ->Dateien festlegen
      Call MeineArbeitsmappen_NamenFestlegen(f_MA(), f_MA_cnt)
      
     ->prüfen: Existenz,->geoeffnet', Name kommt mehrfach vor
      If Not MeineArbeitsmappen_Pruefen(f_MA(), f_MA_cnt) Then Exit Sub
      
     ->Zielmappe anlegen
      Set wbz = Workbooks.Add
     ->überflüssige Blätter löschen
      Application.DisplayAlerts = False
      For x = wbz.Worksheets.Count To 2 Step -1: wbz.Worksheets(x).Delete: Next x
      Application.DisplayAlerts = True
     ->leeres Blatt merken, um es am Ende zu löschen
      Set wsz_leer = wbz.Worksheets(1)
    
     ->Bildschirm-Update abschalten
      Application.ScreenUpdating = False
    
     ->Tabellenblätter kopieren
      Call P_BlatterInZielMappeKopieren(wbz, f_MA(), f_MA_cnt)
      
     ->Bildschirm-Update anschalten
      Application.ScreenUpdating = True
      
     ->überflüssiges Blatt löschen
      If wbz.Worksheets.Count > 1 Then
        Application.DisplayAlerts = False: wsz_leer.Delete: Application.DisplayAlerts = True
      End If
      wbz.Worksheets(1).Select
      
    Aufraeumen:
      Set wbz = Nothing: Set wsz_leer = Nothing
    End Sub
    '***********************************************************
    Private Function P_BlatterInZielMappeKopieren(wbz As Workbook, _
                      f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long)
    
      Dim x As Long, wb As Workbook, ws As Worksheet
      
     ->alle zu bearbeitenden Mappen
      For x = LBound(f_MA()) To UBound(f_MA())
        
       ->Mappe öffnen, wenn noch nicht offen
        If f_MA(x).b_geoeffnet Then
          Set wb = Workbooks(f_MA(x).s_Name)
        Else
          Set wb = Workbooks.Open(f_MA(x).s_FullName)
        End If
       ->alle Arbeitsblätter
        For Each ws In wb.Worksheets
         ->Arbeitsblattname fängt mit->p' an ?
          If p = LCase(Left(ws.Name, 1)) Then
           ->Blatt in Zielmappe kopieren
            ws.Copy After:=wbz.Sheets(wbz.Worksheets.Count)
          End If
        Next
        
       ->wenn Mappe nicht geöffnet war, schliessen
        If Not f_MA(x).b_geoeffnet Then wb.Close savechanges:=False
      
      Next
    Aufraeumen:
      Set wb = Nothing
    End Function
    '***********************************************************
    Private Function MeineArbeitsmappen_NamenFestlegen( _
                      f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long)
      Dim x As Long
                      
      f_MA_cnt = 0: ReDim f_MA(1 To 1)
      
     ->1.Datei
      f_MA_cnt = f_MA_cnt + 1: ReDim Preserve f_MA(1 To f_MA_cnt)
      With f_MA(f_MA_cnt)
        .s_Pfad = c:\Test1       ->Pfad zur Mappe
        .s_Name = TestMappe1.xls ->Dateiname
      End With
      
     ->2.Datei
      f_MA_cnt = f_MA_cnt + 1: ReDim Preserve f_MA(1 To f_MA_cnt)
      With f_MA(f_MA_cnt)
        .s_Pfad = c:\Test2       ->Pfad zur Mappe
        .s_Name = TestMappe1.xls ->Dateiname
      End With
      
     ->3.-nte
     ->....
      
     ->Feld weiter vervollständigen, Flags initialisieren
      For x = 1 To f_MA_cnt
        With f_MA(x)
          .s_FullName = .s_Pfad & Application.PathSeparator & .s_Name
          .b_geoeffnet = False
          .b_NameMehrfach = False
        End With
      Next
      
    End Function
    '***********************************************************
    Private Function MeineArbeitsmappen_Pruefen( _
                      f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long) As Boolean
                      
      Dim wb As Workbook, x As Long, y As Long, b_geoeffnet As Boolean
      
      MeineArbeitsmappen_Pruefen = False
      
     ->Existenz und geoeffnet prüfen
      If f_MA_cnt = 0 Then
        MsgBox (keine Quelldateien angegeben.)
        Exit Function
      End If
      For x = 1 To f_MA_cnt
        With f_MA(x)
         ->vorhanden ?
          If  = Dir(.s_FullName, vbNormal) Then
            MsgBox ( _
              Quell-Datei existiert nicht & vbLf & _
              .s_FullName & vbLf & vbLf & _
              --> Abbruch)
            GoTo Aufraeumen
          End If
         ->geoeffnet ?
          b_geoeffnet = False
          For Each wb In Workbooks
            If LCase(.s_FullName) = LCase(wb.FullName) Then
              .b_geoeffnet = True
              Exit For
            End If
          Next
        End With
      Next x
      
     ->mehrfach vorhanden ?
      For x = 1 To f_MA_cnt
        For y = 1 To f_MA_cnt
          If x <> y Then
            If f_MA(x).s_Name = f_MA(y).s_Name Then
              f_MA(x).b_NameMehrfach = True
              f_MA(y).b_NameMehrfach = True
            End If
          End If
        Next
      Next x
     ->Auswertung mehrfach
      For x = 1 To f_MA_cnt
        If f_MA(x).b_geoeffnet And f_MA(x).b_NameMehrfach Then
          MsgBox ( _
            Der Dateiname-> & f_MA(x).s_Name &-> ist mehrfach vorhanden. & vbLf & _
            Eine Datei gleichen Namens ist geöffnet. & vbLf & _
            Bitte schliessen Sie diese Datei und starten den Makro erneut.)
            GoTo Aufraeumen
        End If
      Next x
     ->2.Auswertung mehrfach
      For x = 1 To f_MA_cnt
        For Each wb In Workbooks
        If LCase(f_MA(x).s_Name) = LCase(wb.Name) And _
            LCase(f_MA(x).s_FullName) <> LCase(wb.FullName) Then
          MsgBox ( _
            Der Dateiname-> & f_MA(x).s_Name &-> ist mehrfach vorhanden. & vbLf & _
            Eine Datei gleichen Namens ist geöffnet. & vbLf & _
            Bitte schliessen Sie diese Datei und starten den Makro erneut.)
            GoTo Aufraeumen
        End If
        Next
      Next x
      MeineArbeitsmappen_Pruefen = True
    Aufraeumen:
      Set wb = Nothing
    End Function
     
     
  5. Hallo Matjes,

    ich brauche noch ein bisschen hilfe.
    Und zwar sollen die Arbeitsblätter nicht einfach in ein neues Excelfile kopiert werden sondern in eine Tabelle namens Master.xls.
    Dabei soll wenn möglich noch abgefragt werden ob die zu kopierenden Arbeitsblätter schon im Master.xls enthalten sind.
    Wenn ja, dann sollen die Blätter im Master zuerst gelöscht werden.

    Vielen Dank im Voraus.

    Grüße
    falcon30
     
  6. Hallo falcon30,

    der Makro ist jetzt deinem Wünsch entsprechend geändert. Pfad und Name der Zieldatei bitte in MeineArbeitsmappen_NamenFestlegen anpassen.

    Als Schmankerl gibts noch die Sortierung der Tabellenblätter in der Zielmappe dazu.

    Gruß Matjes  ;)

    Code:
    Option Explicit
    
    Type my_Arbeitsmappen_structure
     s_Pfad As String
     s_Name As String
     s_FullName As String
     b_geoeffnet As Boolean
     b_NameMehrfach As Boolean
    End Type
    '***********************************************************
    Sub BlaetterMitPBeginnendInNeueArbeitsmappe()
    '*** Aus den definierten Dateien werden die
    '*** Blätter, deren Name mit p/P beginnt,
    '*** in die Arbeitsmappe Master.xls kopiert
    '*** ist ein BlattName in Master.xls schon vorhanden,
    '*** wird das entsprechende Blatt in Master.xls
    '*** gelöscht und dann das neue hineinkopiert.
    '*** Beim Namensvergleich wird Groß/Kleinschreibung
    '*** nicht berücksichtigt!
    '***
    '*** ACHTUNG !!!
    '*** Sind in zwei Quelldateien Blätter, die den
    '*** gleichen Namen haben und deren Name mit p/P
    '*** anfängt, ist zum Schluß nur das Blatt aus
    '*** der zuletzt behandelten Datei in Master.xls
    '*** enthalten.
    '*** ACHTUNG !!!
    '***
    '*** ACHTUNG !!!
    '*** sind auf den kopierten Blättern Zellen,
    '*** deren Inhalt mehr als 255 Zeichen beträgt,
    '*** wird der Inhalt auf 255 Zeichen beschnitten
    '*** ACHTUNG !!!
    
    
    ->Feld meine Arbeitsmappen
     Dim f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long
     
    ->Zieltabelle
     Dim ZielTab As my_Arbeitsmappen_structure
     
     Dim wbz As Workbook, x As Long
     
    ->Dateien festlegen
     Call MeineArbeitsmappen_NamenFestlegen(f_MA(), f_MA_cnt, ZielTab)
     
    ->prüfen: Existenz,->geoeffnet', Name kommt mehrfach vor
     If Not MeineArbeitsmappen_Pruefen( _
         f_MA(), f_MA_cnt, ZielTab) Then Exit Sub
     
    ->Zielmappe öffnen
     If ZielTab.b_geoeffnet Then
      Set wbz = Workbooks(ZielTab.s_Name)
     Else
      Set wbz = Workbooks.Open(ZielTab.s_FullName)
     End If
     
    ->Bildschirm-Update abschalten
     Application.ScreenUpdating = False
    
    ->Tabellenblätter kopieren
     Call P_BlatterInZielMappeKopieren(wbz, f_MA(), f_MA_cnt)
     
    ->Zieldatei - Blätter sortieren
     Call BlaetterInZielDateiSortieren(wbz)
     
    ->Ziel-Datei 1.Tabellenblatt aktivieren
     wbz.Worksheets(1).Select
     
    ->Wenn Ziel-Datei vorher geschlossen war, schliessen
     If Not ZielTab.b_geoeffnet Then
      wbz.Close SaveChanges:=True
     End If
     
    ->Bildschirm-Update anschalten
     Application.ScreenUpdating = True
     
    Aufraeumen:
     Set wbz = Nothing
    End Sub
    '***********************************************************
    Private Function P_BlatterInZielMappeKopieren(wbz As Workbook, _
             f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long)
    
     Dim x As Long, wb As Workbook, ws As Worksheet, wsz As Worksheet
     Dim s_WarEinzigesBlatt As String
     
     s_WarEinzigesBlatt = 
     
    ->alle zu bearbeitenden Mappen
     For x = LBound(f_MA()) To UBound(f_MA())
      
     ->Mappe öffnen, wenn noch nicht offen
      If f_MA(x).b_geoeffnet Then
       Set wb = Workbooks(f_MA(x).s_Name)
      Else
       Set wb = Workbooks.Open(f_MA(x).s_FullName)
      End If
     ->alle Arbeitsblätter
      For Each ws In wb.Worksheets
      ->Arbeitsblattname fängt mit->p' an ?
       If p = LCase(Left(ws.Name, 1)) Then
        
       ->Wenn Blattname in Master.xls schon vorhanden,
       ->entsprechendes Blatt vor dem Kopieren löschen
        For Each wsz In wbz.Worksheets
         If LCase(ws.Name) = LCase(wsz.Name) Then
         ->wenn nicht letztes Blatt
          If wbz.Worksheets.Count > 1 Then
           Application.DisplayAlerts = False
           wsz.Delete
           Application.DisplayAlerts = True
          Else
          ->letztes Blatt
          ->Umbenennen und nach dem Kopieren löschen
           wsz.Name = __NACHKOPIERENLOESCHEN__
           s_WarEinzigesBlatt = wsz.Name
          End If
          Exit For
         End If
        Next
        
       ->Blatt in Zielmappe kopieren
        ws.Copy After:=wbz.Worksheets(1)->### geändert 9.6.2005
        
       ->Wenn das alte Blatt noch gelöscht werden muß-> löschen
        If s_WarEinzigesBlatt <>  Then
         Application.DisplayAlerts = False
         wbz.Worksheets(s_WarEinzigesBlatt).Delete
         Application.DisplayAlerts = True
         s_WarEinzigesBlatt =    ->### geändert 9.6.2005
        End If
       End If
      Next
      
     ->wenn Mappe nicht geöffnet war, schliessen
      If Not f_MA(x).b_geoeffnet Then wb.Close SaveChanges:=False
     
     Next
    Aufraeumen:
     Set wb = Nothing: Set wsz = Nothing: Set ws = Nothing
    End Function
    '***********************************************************
    Private Function MeineArbeitsmappen_NamenFestlegen( _
             f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long, _
             ZielTab As my_Arbeitsmappen_structure)
     Dim x As Long
             
    ->Zieldatei
     With ZielTab
      .s_Pfad = c:\Test1
      .s_Name = Master.xls
      .s_FullName = .s_Pfad & Application.PathSeparator & .s_Name
      .b_NameMehrfach = False
      .b_geoeffnet = False
     End With
             
    ->Quelldateien
     f_MA_cnt = 0: ReDim f_MA(1 To 1)
     
    ->1.Datei
     f_MA_cnt = f_MA_cnt + 1: ReDim Preserve f_MA(1 To f_MA_cnt)
     With f_MA(f_MA_cnt)
      .s_Pfad = c:\Test1   ->Pfad zur Mappe
      .s_Name = TestMappe1.xls->Dateiname
     End With
     
    ->2.Datei
     f_MA_cnt = f_MA_cnt + 1: ReDim Preserve f_MA(1 To f_MA_cnt)
     With f_MA(f_MA_cnt)
      .s_Pfad = c:\Test2   ->Pfad zur Mappe
      .s_Name = TestMappe1.xls->Dateiname
     End With
     
    ->3.-nte
    ->....
     
    ->Feld weiter vervollständigen, Flags initialisieren
     For x = 1 To f_MA_cnt
      With f_MA(x)
       .s_FullName = .s_Pfad & Application.PathSeparator & .s_Name
       .b_geoeffnet = False
       .b_NameMehrfach = False
      End With
     Next
     
    End Function
    '***********************************************************
    Private Function MeineArbeitsmappen_Pruefen( _
             f_MA() As my_Arbeitsmappen_structure, f_MA_cnt As Long, _
             ZielTab As my_Arbeitsmappen_structure) As Boolean
             
     Dim wb As Workbook, x As Long, y As Long
     
     MeineArbeitsmappen_Pruefen = False
     
    ->Zieldatei
    ->vorhanden ?
     With ZielTab
      If  = Dir(.s_FullName, vbNormal) Then
       MsgBox ( _
        Ziel-Datei existiert nicht & vbLf & _
        .s_FullName & vbLf & vbLf & _
        --> Abbruch)
       GoTo Aufraeumen
      End If
     ->geoeffnet ?
      For Each wb In Workbooks
       If LCase(.s_FullName) = LCase(wb.FullName) Then
        .b_geoeffnet = True
        Exit For
       End If
      Next
     End With
     
     
    ->Quelldateien
    ->Existenz und geoeffnet prüfen
     If f_MA_cnt = 0 Then
      MsgBox (keine Quelldateien angegeben.)
      Exit Function
     End If
     For x = 1 To f_MA_cnt
      With f_MA(x)
      ->vorhanden ?
       If  = Dir(.s_FullName, vbNormal) Then
        MsgBox ( _
         Quell-Datei existiert nicht & vbLf & _
         .s_FullName & vbLf & vbLf & _
         --> Abbruch)
        GoTo Aufraeumen
       End If
      ->geoeffnet ?
       For Each wb In Workbooks
        If LCase(.s_FullName) = LCase(wb.FullName) Then
         .b_geoeffnet = True
         Exit For
        End If
       Next
      End With
     Next x
     
    ->mehrfach vorhanden ?
     For x = 1 To f_MA_cnt
      For y = 1 To f_MA_cnt
       If x <> y Then
        If f_MA(x).s_Name = f_MA(y).s_Name Then
         f_MA(x).b_NameMehrfach = True
         f_MA(y).b_NameMehrfach = True
        End If
       End If
      Next
     Next x
    ->Auswertung mehrfach
     For x = 1 To f_MA_cnt
      If f_MA(x).b_geoeffnet And f_MA(x).b_NameMehrfach Then
       MsgBox ( _
        Der Dateiname-> & f_MA(x).s_Name &-> ist mehrfach vorhanden. & vbLf & _
        Eine Datei gleichen Namens ist geöffnet. & vbLf & _
        Bitte schliessen Sie diese Datei und starten den Makro erneut.)
        GoTo Aufraeumen
      End If
     Next x
    ->2.Auswertung mehrfach
     For x = 1 To f_MA_cnt
      For Each wb In Workbooks
      If LCase(f_MA(x).s_Name) = LCase(wb.Name) And _
        LCase(f_MA(x).s_FullName) <> LCase(wb.FullName) Then
       MsgBox ( _
        Der Dateiname-> & f_MA(x).s_Name &-> ist mehrfach vorhanden. & vbLf & _
        Eine Datei gleichen Namens ist geöffnet. & vbLf & _
        Bitte schliessen Sie diese Datei und starten den Makro erneut.)
        GoTo Aufraeumen
      End If
      Next
     Next x
     MeineArbeitsmappen_Pruefen = True
    Aufraeumen:
     Set wb = Nothing
    End Function
    '***********************************************************
    Private Function BlaetterInZielDateiSortieren(wbz As Workbook)
     
     Dim wsz As Worksheet, ws As Worksheet, l_cnt As Long, x As Long
     
    ->Hilfs-Blatt zum sortieren der Blattnamen anlegen
     Set wsz = wbz.Worksheets.Add
     
    ->Blattnamen in Spalte 1 des Hilfsblattes
     l_cnt = 0
     For Each ws In wbz.Worksheets
      l_cnt = l_cnt + 1
      wsz.Cells(l_cnt, 1).Value = ws.Name
     Next
     
     If l_cnt > 1 Then
     ->Blattnamen sortieren
      wsz.Range(wsz.Cells(1, 1), wsz.Cells(l_cnt, 1)).Sort _
       Key1:=wsz.Cells(1, 1), Order1:=xlAscending, _
       Header:=xlNo
       
     ->Blätter entsprechend Sortierung sortieren
      For x = l_cnt To 2 Step -1
       wbz.Worksheets(wsz.Cells(x - 1, 1).Value).Move _
        Before:=wbz.Worksheets(wsz.Cells(x, 1).Value)
      Next
     End If
     
    ->Hilfsblatt wieder löschen
     Application.DisplayAlerts = False
     wsz.Delete
     Application.DisplayAlerts = True
     
    Aufraeumen:
     Set wsz = Nothing: Set ws = Nothing
    End Function
     
  7. Hallo Matjes,

    es funktioniert eigentlich genau so wie ich das mir vorstelle.
    Leider gibt es ein Problem:

    Wenn ich das Makro das zweite Mal starte (hintereinander) dann gibt es eine Fehlermeldung:
    Laufzeitfehler 1004
    Die methode für das Objekt->_Worksheet' ist fehlgeschlagen.

    Wäre toll wenn die Fehlermeldung nicht mehr erscheint.

    Vielen Dank im Voraus.

    Grüße
    Sahin Duygun
     
  8. Hallo Sahin,

    in welcher Zeile steht der Makro dann ?

    Gruß Matjes :)
     
  9. Hallo Matjes,

    bleibt hier stehen:

    ->Blatt in Zielmappe kopieren
    ws.Copy After:=wbz.Sheets(wbz.Worksheets.Count)

    Grüße
    Sahin
     
  10. Hi Falcon,

    hab 2 Zeilen geändert (siehe oben). Die Zeilen sind mit Änderungskennung versehen. Probier es bitte nochmal aus.

    Gruß Matjes :)
     
Die Seite wird geladen...

Excel: Arbeitsblätter kopieren in neue Tabelle - Ähnliche Themen

Forum Datum
Excel: Filtern aus mehreren Arbeitsblättern mit Ergebniss in einem neuen AB Windows XP Forum 30. Jan. 2008
Formatierung von Excel Arbeitsblättern Windows XP Forum 17. Feb. 2003
Excel-Feature gesucht Microsoft Office Suite 11. Okt. 2016
Excel Tabelle Werte zu ordnen Microsoft Office Suite 23. Sep. 2016
Excel: Bereiche auf 'leer' Überprüfen Microsoft Office Suite 15. Sep. 2016