Aus mehreren Excel-Dateien bestimmte Zellen auslesen

[Günti]

Hallo,

ich will in einem Verzeichnis aus mehreren Excel-Dateien bestimmte Zeilen auslesen.
Ich habe ein Beispiel gefunden und kann aber nur aus meinem Tabellenblatt
"Yieldverlauf über 2 Monate" die Zeile 2 oder Zeile 3 auslesen.
Wie kann ich beide Zeilen (2 und 3) auslesen ?

Wenn ich in der Zeile:

arr(z, x) = "='" & sSourcePath & "\[" & oFile.Name & "]" & sSourceSheet & "'!$" & i & "$2" 'Array füllen

den Wert $2 oder $3 eintrage wird immer nur die zweite oder dritte Zeile ausgelesen.

Den Code und und zwei Dateien hänge ich an.

Kann mir jemand einen Tip geben ?

Danke und Gruß
Günti

Code:

Sub Zusammenfassen_Excel_Dateien()
Dim sSourcePath As String, sSourceSheet As String
Dim arr, z As Integer, i, x As Integer, oFile, fso
Dim wbges As Workbook, wsziel As Worksheet
sSourcePath = "C:\PG500\Inf-Files" ' Pfad
sSourceSheet = "Yieldverlauf über 2 Monate" ' Tabellenname aus der Quelldatei
Set wbges = ActiveWorkbook 'aktuelle Datei, Zieldatei
Set wsziel = ActiveWorkbook.ActiveSheet 'aktuelles Tabellenblatt der Zieldatei
Set fso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False 'während der folgenden Aktionen Bildschirm einfrieren
ReDim arr(fso.GetFolder(sSourcePath).Files.Count, 10) 'Array dimensionieren
For Each oFile In fso.GetFolder(sSourcePath).Files 'alle Quelldateien im Verzeichnis durchlaufen
If LCase(fso.getextensionname(oFile.Name)) = "xlsx" Then 'nur xlsx-Dateien bearbeiten
For Each i In Array("a", "b", "c")
arr(z, x) = "='" & sSourcePath & "\[" & oFile.Name & "]" & sSourceSheet & "'!$" & i & "$2" 'Array füllen
x = x + 1 'Laufende Spaltennummer im Array
Next
x = 0: z = z + 1
End If
Next 'Datei
Application.ScreenUpdating = True 'Bildschirmanzeige wiederauftauen
With wsziel
.Range(.Cells(2, 1), .Cells(UBound(arr) + 2, 11)) = arr 'Array ausgeben
 With .Range(.Cells(2, 1), .Cells(UBound(arr) + 2, 11))
 .Value = .Value
 End With
End With

'Anpassung der Spaltenbreite
   Call ActiveSheet.Columns.AutoFit
   
'Zahlenformat festlegen
   Range("B:B").NumberFormat = "#,##0.00"

wbges.Save 'ZielDatei speichern
MsgBox "Fertig"
End Sub

[Käpt'n Blaubär]

Hallo Günti,

ok, ... "falscher Fehler" von mir , sorry

[schauan]

Hallöchen,

da wäre die Frage, wie die Daten im Ziel angeordnet werden sollen.
Eine Variante wäre, eine 3. Schleife um die beiden anderen zu bauen, und darin die 2 und die 3 zu wechseln.
Eine andere Variante wäre, in der bestehenden Schleife nach x=x+1 die 3. Zeile zu übernehmen und dann x nochmal um 1 zu erhöhen.

Da das Array dann doppelt so groß ist, müsstest Du weiter oben den Wert beim Redim auch verdoppeln und unten beim Eintrag der Werte auch erhöhen.

[Günti]

Hallo,

das mit dem Array ist glaube ich zu komplizert für nur 6 Zellen.

In der Quelle sind einfach 2 Zeilen mit jeweils 3 Zellen auszulesen.
Das Blatt heißt in jeder Quelldatei immer gleich (Yieldverlauf über 2 Monate)
und die Zellen sind immer A2 bis C3.

Im Ziel müssen die Zellen in der gleichen Form wie in der Quelle
fortlaufend aufgelistet werden.
Erste Excel Datei: A2 bis C3
Zweite Excel Datei: A5 bis C6
Dritte Excel Datei: A8 bis C9
usw.

Kann ich das vielleicht nicht einfacher mit 6 Variablen machen
und das Array weglassen ?


Danke und Gruß
Günti

[schauan]

Hallo Günti,

Du kannst natürlich auch ohne Array arbeiten und die Formeln gleich in die Zellen eintragen. Allerdings ist die Variante über ein Array in der Regel schneller und Du hast damit, wenn's wirklich darauf ankommt, auch gleich mehr Erfahrung damit.

[Günti]

Hallo,

ich habe die Lösung jetzt gefunden.
Hier ist der Code:

Code:

Sub prcForm()
  Dim lngC As Long, lngA As Long
  Dim strPath As String
  Dim strDatei As String
  Dim vntZellAdressen As Variant
  
  lngC = 6
  vntZellAdressen = Array("A2", "B2", "C2", "A3", "B3", "C3")
  strPath = "C:\PG500\Inf-Files\"
  strDatei = Dir(strPath & "*.xlsx")
  
  Do While strDatei <> ""
     Workbooks.Open (strPath & strDatei)
     For lngA = 0 To UBound(vntZellAdressen)
        ActiveWorkbook.Worksheets(3).Range(vntZellAdressen(lngA)).Copy ThisWorkbook.Worksheets(1).Cells(lngC, lngA + 1)
     Next lngA
    lngC = lngC + 1
     ActiveWorkbook.Close False
     strDatei = Dir
  Loop
  
   'Anpassung der Spaltenbreite
    Call ActiveSheet.Columns.AutoFit
  
End Sub

Trotzdem vielen Dank für die Mühe.

Gruß
Günti