vba Zusammenfassung mehrerer Tabllen

[aeugeln]

Hallo, folgende Situation: Ich möchte gerne den Inhalt aus 12 Einzeldateien mit je 4 Datenblättern (die sich vom Aufbau aber leicht unterscheiden) auslesen und in einer Master-Datei zusammen fassen lassen.

Die Dateien sind komplett identisch aufgebaut, sodass eigentlich nur die 12 Dateien geöffnet werden müssen und bspw. für Worksheet("Personal") ab Zelle E13 geprüft wird, ob ein Eintrag vorhanden ist und wenn ja diese Zeile bis Q13 in die Master-Datei (Worksheet "Personal" Zelle E13-Q13) kopieren. Das Ziel hat ja auch die gleiche Formatierung.

Dann weiterprüfen ob E14 in der Quelle einen Eintrag hat und ggf wieder in Master-Datei kopieren, aber dann eben bei E14-Q14 einfügen, hier muss die erste freie Zeile gefunden werden oder so.

Wenn dann kein Eintrag in Spalte E mehr kommt, dann müsste er zum nächsten Datenblatt und das gleiche nochmal machen. Das für jedes Datenblatt und dann weiter mit der nächsten Datei

Kann mir hier jemand mit einem bereits vorhandenem Codeschnipsel helfen an dem ich mich probieren könnte?

Vielen Dank.

Beste Grüße
Michael

[Rabe]

Hi,

sind alle Dateien im gleichen Verzeichnis?
Wie heißen die Dateien?
Wie heißen die Datenblätter?
Was ist mit Doppeleinträgen?

Du könntest den Vorgang mal mit dem Makrorekorder an einer Datei aufzeichnen und dann das Makro hier posten. Dann können wir es verallgemeinern und entrümpeln.

[Steffl]

Hallo,

mal ein Ansatz

Code:

Sub prcMichael()

   Dim objFolder As Object, objSubFolder As Object
   Dim lngTab As Long, lngC As Long, lngA As Long, lngEnde As Long
   Dim strDatei As String
  
   On Error Resume Next
   With ThisWorkbook.Worksheets("Personal")
      lngC = .Cells(.Rows.Count, 5).End(xlUp).Row
   End With
   If lngC < 13 Then lngC = 13
   Set objFolder = CreateObject("Scripting.FileSystemObject").getfolder(ThisWorkbook.Path)
   strDatei = Dir(ThisWorkbook.Path & "\*.xls*")
   Do While strDatei <> ""
      If strDatei <> ThisWorkbook.Name Then Workbooks.Open ThisWorkbook.Path & "\" & strDatei
      For lngTab = 1 To 4
         With ActiveWorkbook.Worksheets(lngTab)
            lngEnde = .Cells(.Rows.Count, 5).End(xlUp).Row
            For lngA = 13 To lngEnde
               If .Cells(lngA, 5) <> "" Then
                  .Cells(lngA, 5).Resize(, 13).Copy ThisWorkbook.Worksheets("Personal").Cells(lngC, 5)
                  lngC = lngC + 1
               End If
            Next lngA
         End With
      Next lngTab
      ActiveWorkbook.Close False
      strDatei = Dir()
   Loop
   On Error GoTo 0
End Sub

Voraussetzung: Dateien befinden sich im selben Verzeichnis.

[aeugeln]

Hi,

sind alle Dateien im gleichen Verzeichnis?
Wie heißen die Dateien?
Wie heißen die Datenblätter?
Was ist mit Doppeleinträgen?

Du könntest den Vorgang mal mit dem Makrorekorder an einer Datei aufzeichnen und dann das Makro hier posten. Dann können wir es verallgemeinern und entrümpeln.

Hey, also da bin ich sehr flexibel, aber die 12 Einzeldateien liegen aktuell im gleichen Ordner, die Masterdatei wollte ich eine Ebene höher ablegen.

Die Dateien heißen EUR-01.xlsx bis EUR-12.xlsx.

Die Datenblätter: Personal / Reise-Aufenthaltskosten / Dienstleistungen / Verwaltung

Doppeleinträge gibt es nicht. Das mit dem Makrorekorder mache ich gleich.

Beste Grüße

[aeugeln]

Du könntest den Vorgang mal mit dem Makrorekorder an einer Datei aufzeichnen und dann das Makro hier posten. Dann können wir es verallgemeinern und entrümpeln.

Code:

Sub Makro7()
'
' Makro7 Makro
'

'
   Range("E13").Select
   ActiveWindow.ScrollColumn = 6
   ActiveWindow.ScrollColumn = 7
   ActiveWindow.ScrollColumn = 8
   Range("E13:Q13").Select
   Selection.Copy
   Windows("Master.xlsm").Activate
   ActiveSheet.Paste
   Windows("EUR-01.xlsx").Activate
   Sheets("Reise-Aufenthaltskosten").Select
   Range("E14").Select
   ActiveWindow.ScrollColumn = 6
   ActiveWindow.ScrollColumn = 7
   ActiveWindow.ScrollColumn = 8
   ActiveWindow.ScrollColumn = 9
   ActiveWindow.ScrollColumn = 10
   ActiveWindow.ScrollColumn = 11
   ActiveWindow.ScrollColumn = 12
   ActiveWindow.ScrollColumn = 13
   ActiveWindow.ScrollColumn = 14
   ActiveWindow.ScrollColumn = 15
   ActiveWindow.ScrollColumn = 16
   ActiveWindow.ScrollColumn = 17
   Range("E14:AE14").Select
   Application.CutCopyMode = False
   Selection.Copy
   Windows("Master.xlsm").Activate
   Sheets("Reise-Aufenthaltskosten").Select
   Range("E14").Select
   ActiveSheet.Paste
   Windows("EUR-01.xlsx").Activate
   Sheets("Dienstleistungen").Select
   Range("E14").Select
   Sheets("Verwaltung").Select
   Range("E14").Select
   ActiveWindow.ScrollColumn = 6
   ActiveWindow.ScrollColumn = 9
   ActiveWindow.ScrollColumn = 13
   ActiveWindow.ScrollColumn = 14
   Range("E14:V15").Select
   Application.CutCopyMode = False
   Selection.Copy
   Windows("Master.xlsm").Activate
   Sheets("Verwaltung").Select
   ActiveSheet.Paste
   Windows("EUR-01.xlsx").Activate
   ActiveWindow.Close
   ActiveWindow.LargeScroll ToRight:=-1
   Sheets("Personal").Select
   Range("E13").Select
   ActiveWindow.ScrollColumn = 6
   Range("E13:Q14").Select
   Selection.Copy
   Windows("Master.xlsm").Activate
   Sheets("Personal").Select
   Range("E14").Select
   ActiveSheet.Paste
   Windows("EUR-02.xlsx").Activate
   Sheets("Reise-Aufenthaltskosten").Select
   Range("E14").Select
   ActiveWindow.ScrollColumn = 6
   ActiveWindow.ScrollColumn = 7
   ActiveWindow.ScrollColumn = 8
   ActiveWindow.ScrollColumn = 9
   ActiveWindow.ScrollColumn = 10
   ActiveWindow.ScrollColumn = 11
   ActiveWindow.ScrollColumn = 12
   ActiveWindow.SmallScroll ToRight:=5
   Range("E14:AE14").Select
   Application.CutCopyMode = False
   Selection.Copy
   Windows("Master.xlsm").Activate
   Sheets("Dienstleistungen").Select
   ActiveSheet.Paste
   Windows("EUR-02.xlsx").Activate
   Sheets("Verwaltung").Select
   Range("E14:F14").Select
   ActiveWindow.ScrollColumn = 6
   ActiveWindow.ScrollColumn = 8
   ActiveWindow.ScrollColumn = 10
   ActiveWindow.ScrollColumn = 11
   ActiveWindow.ScrollColumn = 12
   ActiveWindow.ScrollColumn = 13
   Range("E14:V18").Select
   Application.CutCopyMode = False
   Selection.Copy
   Windows("Master.xlsm").Activate
   Sheets("Verwaltung").Select
   Range("E16").Select
   ActiveSheet.Paste
   Windows("EUR-02.xlsx").Activate
   ActiveWindow.Close
End Sub

Wenn kein Kopiervorgang stattgefunden hat, dann waren keine Einträge vorhanden. Bei dem Code fehlt am Anfang, dass ich mich im Sheets("Personal") befinde.

[Rabe]

Hi,

ich habe Dein Makro entrümpelt und zusammengefasst. Teste es bitte, ob es noch dassselbe tut, wie vorher und das, was es soll:

Code:

Sub Makro7()
  '
  ' Makro7 Makro
  '
 
  '
  Worksheets("Personal").Range("E13:Q13").Copy
  Windows("Master.xlsm").Activate
  ActiveSheet.Paste
 
  With Windows("EUR-01.xlsx")
     .Sheets("Reise-Aufenthaltskosten").Range("E14:AE14").Copy
     Windows("Master.xlsm").Sheets("Reise-Aufenthaltskosten").Range("E14").Paste
     
     .Sheets("Verwaltung").Range("E14:V15").Copy
     Windows("Master.xlsm").Sheets("Verwaltung").Paste
     .Close
  End With
 
  Sheets("Personal").Range("E13:Q14").Copy
  Windows("Master.xlsm").Sheets("Personal").Range("E14").Paste
 
  With Windows("EUR-02.xlsx")
     .Sheets("Reise-Aufenthaltskosten").Range("E14:AE14").Copy
     Windows("Master.xlsm").Sheets("Dienstleistungen").Paste
     
     .Sheets("Verwaltung").Range("E14:V18").Copy
     Windows("Master.xlsm").Sheets("Verwaltung").Range("E16").Paste
     .Close
  End With
End Sub