Daten aus mehreren ExcelDateien in eine Masterdatei schreiben

[KBKK]

Hallo zusammen,

mein Ziel ist es ein Makro zu schreiben mit dem ich durch starten im Mastersheet Dateien auswählen kann von denen im Zweiten Reiter die Daten aus A7:H22 kopiert und im Mastersheet untereinander eingefügt werden.
Ich habe mir folgenden Code aus dem Internet zusammenkopiert.

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 shcount As Integer
' DIM i FÜR DIE SCHLEIFE DURCH DIE ARBEITSBLÄTTER; JEDES i = EIN BLATT
Dim i As Integer

' 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)
    ' ZÄHLUNG DER VORHANDENEN ARBEITSBLÄTTER IN "wbPro"
    shcount = wbPro.Worksheets.Count


'######################################
'# BEGINN DES LOOPS durch die Sheets  #
'######################################

' JEDES i IST EIN WORKSHEET IN DER ZUR ZEIT GEÖFFNETEN DATEI "f", GENANNT wbPro
' IN DIESEM FALL LOOPT DAS SCRIPT NIHCT DURCH ALLE SHEETS, Sondern nimmt das zweite Sheet
For i = 2 To i = 2
    With wbPro.Worksheets(i)
    
    ' 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 = wbPro.Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Row


'######################################
'# BEGINN DES LOOPS durch das BLATT i #
'######################################

' FÜR JEDES J VON ZEILE 7 (erste Zeile der Daten) BIS LR (letzte beschriebene Zeile)
Dim j As Integer
For j = 7 To LR - 1
' INNERHALB DIESES LOOPS DURCH DIE ZEILEN MUSS LR_Ziel IMMER WIEDER NEU ERMITTELT WERDEN, UM JEDEN EINTRAG UNTER DEN VORHERIGEN ZU SCHREIBEN.
' HIER SCHON IN DER ERMITTLUNG MIT + 1, SODASS LR_Ziel NUN DIE ERSTE LEERE ZEILE IM ZIEL IST
LR_Ziel = wSZiel.Cells(Rows.Count, 1).End(xlUp).Row + 1



' NUN WERDEN INS ZIEL DIE WERTE AUS DER AKTUELLEN ZEILE j WEGGESCHRIEBEN.
wSZiel.Cells(LR_Ziel, 1).Value = wbPro.Cells(j, 1).Value
wSZiel.Cells(LR_Ziel, 2).Value = wbPro.Cells(j, 2).Value
wSZiel.Cells(LR_Ziel, 3).Value = wbPro.Cells(j, 3).Value
wSZiel.Cells(LR_Ziel, 4).Value = wbPro.Cells(j, 4).Value
wSZiel.Cells(LR_Ziel, 5).Value = wbPro.Cells(j, 5).Value
wSZiel.Cells(LR_Ziel, 6).Value = wbPro.Cells(j, 6).Value
wSZiel.Cells(LR_Ziel, 7).Value = wbPro.Cells(j, 7).Value
wSZiel.Cells(LR_Ziel, 8).Value = wbPro.Cells(j, 8).Value

'######################################
'#  NÄCHSTE ZEILE IM AKTUELLEN BLATT  #
'######################################
Next j

End With
'#########################################
'# NÄCHSTES BLATT IN DER AKTUELLEN DATEI #
'#########################################
Next i

' 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

Das Makro läuft soweit ohne Fehlermeldung durch und ich kann Anfangs auch die Dateien auswählen alelrdings wird nichts in mein Mastersheet kopiert.

Vielen Dank für eure Hilfe und entschuldigt bitte falls es sich im banale Fehler handelt hatte erst letzte Woche meinen VBA einführungskurs :29:

[MisterBurns]

Hallo,

ohne mich jetzt durch deinen ganzen Code geackert zu haben (denn das macht mir keinen Spaß), empfehle ich dir, den Code schrittweise mit F8 durchlaufen zu lassen. Damit siehst du sofort, welcher Schritt was (nicht) macht und kann das ist oft sehr hilfreich (nicht vergessen Application.ScreenUpdating = False auszukommentieren, sonst siehst du gar nix).

Kleiner Hinweis noch für das Posten hier im Forum: Bitte setze Codes in Codetags, das erleichtert das Lesen ungemein.
["code"] Dein Code hier ["/code"]
nur ohne die Anführungszeichen in den eckigen Klammern.

[Käpt'n Blaubär]

Hallo,

... auch ich habe aufgegeben, mich durch den Code zu quälen.

Danke, Berni

[KBKK]

Vielen Dank für die schnellen Antworten und sorry für die Unübersichtlichkeit. Eure Tipps haben mir direkt geholfen das Problem weiter einzugrenzen.

Wenn ich über

Code:

shcount = wbPro.Worksheets.Count

die Reiter durchzählen lasse, wie kann ich ihm dann sagen das er im 2. Reiter etwas auswählen soll?

Code:

Worksheets(2).Range("A7:H22").Select

    Selection.Copy

Das funktioniert nur wenn ich mich bereits im 2. Reiter befinde.

Vielen Dank für eure Hilfe!

[MisterBurns]

Grundsätzlich sollte man auf .Select verzichten, weil es unnötig ist und damit einfach nur der Cursor durch die Mappe gejagt wird. Um deine Frage trotzdem zu beantworten - aktiviere das jeweilige Sheet zuerst

Code:

Worksheets(2).Activate
Worksheets(2).Range("A7:H22").Select

   Selection.Copy

Aber wie erwähnt, lass das lieber. Das geht weit eleganter, zB über

Code:

Sheets(2).Range("A7:H22").Copy Destination:=Sheets("DeinBlatt").Range("A5")

oder

Code:

Sheets("DeinBlatt").Range("A5:H20").Value = Sheets(2).Range("A7:H22").Value

[KBKK]

Vielen dank für den Tipp für die elegantere Varianten.
Hab es versucht umzusetzen, da aber auch davor schon nicht funktioniert hat das kopierte in eine andere Datei zu schreiben hat dein Ansatz auch nicht geklappt.

Code:

' DIM DES ZIELS ALS ARBEITSMAPPE
Dim wbZiel As Workbook
' DIM DES ZIELS ALS ARBEITSBLATT
Dim wSZiel As Worksheet
' DIESE ARBEITSMAPPE ALS ZIEL FESTLEGEN
Set wbZiel = ThisWorkbook
Set wSZiel = wbZiel.Worksheets(1)

Damit habe ich versucht meine Datei aus der ich das Makro starten möchte als Ziel festzulegen.

Code:

Sheets(wSZiel).Range("A5:H20").Value = Sheets(2).Range("A7:H22").Value

[Käpt'n Blaubär]

Hallo,

wir wären wahrscheinlich schon um Einiges weiter, wenn Du statt uns irgendwelche Knochenteile mal endlich den
gesamten Code zeigen würdest.
Ich habe absolut keinen Bock drauf, Stückchen für Stückchen jeweils den benötigten Code anfordern zu müssen.

[schauan]

Hallöchen,

Sheets(wSZiel).Range("A5:H20").Value = Sheets(2).Range("A7:H22").Value

Wenn Du das Makro startest, wenn die Datei aktiv ist, wo es drin steht, dann ist auch das Quellblatt in dieser Datei.
Soll das Quellblatt aus einer anderen Datei sein, müsstest Du entweder sicherstellen, dass beim Durchlauf dieser Befehlszeile die Quelldatei aktiv ist, oder Du musst die Quelle ähnlich dem Ziel im Code verdrahten.

[KBKK]

Hallo,

wir wären wahrscheinlich schon um Einiges weiter, wenn Du statt uns irgendwelche Knochenteile mal endlich den
gesamten Code zeigen würdest.
Ich habe absolut keinen Bock drauf, Stückchen für Stückchen jeweils den benötigten Code anfordern zu müssen.

Zunächst wurde mir ja gesagt, dass es zu anstrengend ist sich durch den kompletten Code zu arbeiten. Außerdem habe ich den ja größtenteils aus dem Internet kopiert und füge aktuell nur Stück für Stück hinzu was ich benötige (viel trial and error )
Ich versuche jetzt mal den Code zu entrümpel dann poste ich ihn nochmal.

[KBKK]

Zunächst mal der Teil der mMn funktioniert. Zumindest das auswählen und öffnen der Dateien. Ob ich bei den dims alles richtig habe weiß ich nicht genau:

Code:

Code:

ub 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 shcount As Integer

' 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)
    ' ZÄHLUNG DER VORHANDENEN ARBEITSBLÄTTER IN "wbPro"
    shcount = wbPro.Worksheets.Count

Nun ist das Arbeitsblatt aus dem ich etwas kopieren und in das Mastersheet (in dem ich das Makro starte) offen.

Ich hatte ein paar schönere Ansätze aber die wollten einfach nicht funktionieren. Habe das ganze jetzt mal unschön gemacht, aber dafür macht es für diesen speziellen Fall was er machen soll.


Code:

Code:

'
 Sheets(2).Activate
    Range("A7:H22").Select
    Selection.Copy

Windows("AOK(18).xlsx").Activate
    
    'Variablendeklaration
    Dim Zelle, I
    
    'For-Next-Schleife sucht nächste freie Zelle
For I = 2 To 1000000
    If Range("A" & I) = "" Then
        Zelle = "A" & I
        Exit For
    End If
Next I
    
    'Jetzt Menge in die Zelle schreiben
    Range(Zelle).Select
    ActiveSheet.Paste

' AKTUELLE DATEI SCHLIESSEN, OHNE SIE ZU SPEICHERN!

wbPro.Close False
'######################################
'#           NÄCHSTE DATEI            #
'######################################
Next f

' BILDSCHIRMAKTUALISIERUNG (ANZEIGE) WIEDER AN!
Application.ScreenUpdating = True

'######################################
'#               FERTIG               #
'######################################
End Sub