Excel: Arbeitsblätter kopieren in neue Tabelle

  • #1
F

falcon30

Guest
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 :)
 
  • #11
Hallo Matjes,

leider tuts noch nicht. Wenn der Inhalt von mehr als 3 Dateien kopiert werden soll, dann stürzt das ganze ab und zwar mit

Laufzeitfehler 1004
Die methode für das Objekt->_Worksheet' ist fehlgeschlagen

Liegt es an der Speicherverwaltung? Kann man unter Excel nach kopiebefehlern den Speicher wieder freigeben?

Grüße
falcon30
 
  • #12
Hallo Zusammen,

wenn ich das ganze mit einer Schaltfläche starten will, was muss ich da ändern?

Grüße
falcon30
 
  • #13
Hallo falcon,

ich hab das bei mir nochmal ausprobiert - 20 Dateien , jeweils 3 Tabs mit p , ein Teil der Dateien war geöffnet Dateien.
Resultat -> läuft, Fehler nicht nachstellbar.

Um an den Fehler heranzukommen, würde ich folgendermassen vorgehen:

In MeineArbeitsmappen_NamenFestlegen alle Blöcke für Quell-Dateien auskommentieren.
Dann einen Quell-Datei-Block entkommentieren und Makro laufen lassen.
Bei positivem Ergebnis nächsten Block entkommentieren , Makro laufen lassen.
Bei negativem Ergebnis, zuletzt entkommentierten Block wieder auskommentieren und nächsten Block entkommentieren und Makro laufen lassen.
Das ganze solange bis all Quell-Datei-Blöcke ausprobiert wurden.

Vielleicht wird so sichtbar, was da besonders zu berücksichtigen ist.


Zur Schaltfläche:
Was für eine Schaltfläche ? In der Menüleiste oder auf dem Arbeitsblatt ?

Gruß Matjes :)
 
  • #14
Hallo Matjes,

ich habe festgestellt dass die Fehlermeldung nur unregelmäßig auf tritt , deshalb werde ich keine weiteren Untersuchungen durchführen.

Das mit der Schaltfläche habe ich so gelöst:

Private Sub Projekttabellenholen_Click()
BlaetterMitPBeginnendInNeueArbeitsmappe
End Sub

Und es tutet.

Vielen Dank!!

Bin echt froh dass es dieses Forum gibt!!

Grüße
falcon30
 
  • #15
Hallo falcon,

'nix für', wie der Norddeutsch sagt  :D

Wenn der->Wackelkontakt' öfters auftritt, wäre ich an der Ursache schon interessiert.

Gruß Matjes :)
 
Thema:

Excel: Arbeitsblätter kopieren in neue Tabelle

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.838
Beiträge
707.959
Mitglieder
51.491
Neuestes Mitglied
haraldmuc
Oben