Daten aus mehreren ExcelDateien in eine Masterdatei schreiben

[schauan]

Hallöchen,

wie gesagt, schaue vor allem mal, ob Du immer auf dem richtigen Blatt bist. Den Code kannst Du z.B. mit F8 schrittweise durchlaufen und dann immer kontrollieren, wo Du bist und was passiert.

[Paule]

Sorry

[Gast 123]

Hallo

ich hatte mir auch mal Gedanken gemacht und den Code überarbeitet, weil mir Unstimmigkeiten auffielen.
Die Schleife für alle Sheets halte ich für Übderflüssig weil nurdas  Shett(2) kopiert wird.

Statt einer Schleife für alle Einzeldaten zu kopieren kann man mit Copy den ganzen Block kopieren.
Bitte mal testen ob diese Version lauffähig ist??

mfg  Gast 123

Code:

Sub Workbook_Open()
' BILDSCHIRMAKTUALISIERUNG (ANZEIGE) AUS!
Application.ScreenUpdating = False

' DIM DER PROJEKTE ALS ARBEITSMAPPEN
Dim wbPro As Workbook
' DIM DES ZIELS ALS ARBEITSMAPPE
Dim wbZiel As Workbook
' DIM DES ZIELS ALS ARBEITSBLATT
Dim wSZiel As Worksheet
' DIM DER ANZAHL DER IN DEN PROJEKTEN ENTHALTENEN BLÄTTER
Dim i As Integer
' DIM i FÜR DIE SCHLEIFE DURCH DIE ARBEITSBLÄTTER; JEDES i = EIN BLATT

' DIESE ARBEITSMAPPE ALS ZIEL FESTLEGEN
Set wbZiel = ThisWorkbook
Set wSZiel = wbZiel.Worksheets(1)

' DIMs FÜR DIE DATEIAUSWAHL
Dim filenames, f
   Dim x As Integer
   Dim myMsg As String
   ' DATEIDIALOG IM PFAD DIESER MAPPE ÖFFNEN
   ChDir ThisWorkbook.Path
   ' filenames = DIE NAMEN DER AUSGEÄHLTEN PROJEKTE
   filenames = Application.GetOpenFilename(FileFilter:="Excel VBA files (*.xls*), *.xls*", _
       FilterIndex:=1, Title:="Bitte wähle die Projekte aus!", MultiSelect:=True)
   ' WENN filenames NAMEN ENTHÄLT (>0) DANN IST X DIE ANZAHL
   If IsArray(filenames) Then
       x = UBound(filenames) - LBound(filenames) + 1
       myMsg = "Du hast " & x & " Projekte ausgewählt."
       'Display full path and name of the files
       MsgBox myMsg
   Else
       MsgBox "Du hast keine Projekte ausgewählt!"
       Exit Sub
   End If


'######################################
'# BEGINN DES LOOPS durch die Dateien #
'######################################

' f IST DER DATEINAME, ALSO NACHFOLGENDER CODE WIRD FÜR JEDE DATEI DURCHLAUFEN
For Each f In filenames
   ' "wbPro" IST NUN DIE DATEI MIT DEM NAMEN AUS "f"; DIESE WIRD GEÖFFNET
   Set wbPro = Workbooks.Open(Filename:=f)

   With wbPro.Worksheets(2)
   ' NEUE ERMITTLUNG DER LETZTEN GEFÜLLTEN ZEILE IM ZIELARBEITSBLATT; HIER IN SPALTE 1 (A)
   Dim LR_Ziel As Integer
   LR_Ziel = wSZiel.Cells(Rows.Count, 1).End(xlUp).Row

   ' AKTIVIERUNG DES ZIELS, UM ZELLEN MARKIEREN ZU KÖNNEN
   wSZiel.Activate
   ' MARKIERUNG DER ZELLEN VON SPALTE 1 BIS 8 (A-H), 1 ZEILEN UNTERHALB DER LETZTEN GEFÜLLTEN ZEILE IN C
   wSZiel.Range(Cells(LR_Ziel + 1, 1), Cells(LR_Ziel + 1, 8)).Select

   ' JETZT WIRD DIE LETZTE BESCHRIEBENE ZELLE IM AKTUELLEN BLATT ERMITTELT (LR), HIER IN SPALTE 1
   Dim LR As Integer
   LR = wSZiel.Cells(Rows.Count, 1).End(xlUp).Row
   
   '##  NEUER BLOCK -OHNE- FOR i SCHLEIFE  ##
   '2 KOPIER UND PASTE VERSIONEN MÖGLICH
   ' WBPRO.SHEET(2).RANGE A7:H22  kopieren
   .Range("A7:H22").Copy      'ganzen Bereich      (kopiert auch Leerzeilen mit!)
   'ODER:
   .Range("A7:H" & LR).Copy   'oder bis LastCell   (kopiert bis letzte gefüllte zelle))
   
   ' DATEN IN WSZIEL EINFÜGEN
   ' WERTE UND FORMATE EINFÜGEN
   wSZiel.Cells(LR_Ziel, 1).PasteSpecial xlPasteAll
   'ODER:   NUR WERTE EINFÜGEN
   wSZiel.Cells(LR_Ziel, 1).PasteSpecial xlPasteValues

   End With

   ' DATEI FERTIG WEGGESCHRIEBEN!!!!!!!!!
   ' AKTUELLE DATEI SCHLIESSEN, OHNE SIE ZU SPEICHERN!
   wbPro.Close False
'######################################
'#           NÄCHSTE DATEI            #
'######################################
Next f

' ALLE ZEILEN ALLER BLÄTTER ALLER DATEIEN INS ZIEL GESCHRIEBEN!
' BILDSCHIRMAKTUALISIERUNG (ANZEIGE) WIEDER AN!
Application.ScreenUpdating = True

End Sub