Hallo EXCEL-Freunde,
ich suche eine Lösung mit der ich bestimmte Werte aus mehreren Dateien auslesen
bzw. rauskopieren kann. In der Recherche habe ich diesen Code von Ramses gefunden:
https://www.herber.de/forum/archiv/396to400/t397306.htm
Jetzt bräuchte ich zwei Anpassungen, die ich zwar realisieren kann, allerdings
geht dies sicher mit Schleifen einfacher:
1. Die betroffenen Dateinamen habe ich in einer Tabelle "Anzrel" hinterlegt (immer gleicher Pfad)
2. Die betroffenen Tabellennamen habe ich in einer Tabelle "Anzrel" hinterlegt

Anzrel

B C 1 Dateiname Tabelle 2 testklaus1 A_1TM 3 testklaus1 A_2RZ 4 testklaus1 B_1JU 5 testklaus2 B_22K 6 testklaus2 CH_1SL 7 testklaus2 CH_2CL

Diagramm - Grafik - Excel Tabellen einfach im Web darstellen    Excel Jeanie HTML  3.0    Download  
Ich habe in dem o.g. Code nun die betroffenen Passagen angepasst und suche
eine Verschlankung durch Schleifen,
Schleife 1 für die Abarbeitung der Dateinamen
Schleife 2 für die Abarbeitung der Tabellennamen
(derzeit 2 bzw. 3, können aber jeweils noch mehr werden)
So sieht der code nun aus (läuft auch), aber wer kann mir bei den Schleifen noch
helfen:

Option Explicit
Sub Dateien_in_eine_Tabelle_zusammenfuehrentest()
'by Ramses
Dim myFso As Object, myFld As Object, Exfiles As Object
Dim xlFile As Object, wbMainBook As Workbook, wbDataBook As Workbook
Dim iCounter As Integer, lgRow As Long
Dim myDat1 As String, myDat2 As String
Dim myName11 As String, myName12 As String, myName13 As String
Dim myName21 As String, myName22 As String, myName23 As String
myDat1 = Sheets("Anzrel").Cells(2, 2)
myName11 = Sheets("Anzrel").Cells(2, 3)
myName12 = Sheets("Anzrel").Cells(3, 3)
myName13 = Sheets("Anzrel").Cells(4, 3)
myDat2 = Sheets("Anzrel").Cells(5, 2)
myName21 = Sheets("Anzrel").Cells(5, 3)
myName22 = Sheets("Anzrel").Cells(6, 3)
myName23 = Sheets("Anzrel").Cells(7, 3)
Application.DisplayAlerts = False
'Sollte aktiviert werden wegen Bildschirmflackern
Application.ScreenUpdating = False
'Erstellt neue Mappe für die Datenausgabe
Set wbMainBook = Workbooks.Add
'Zeilenzähler initialisieren
iCounter = 1
Set myFso = CreateObject("Scripting.FileSystemObject")
Set myFld = myFso.GetFolder("D:\Testen\")
Set Exfiles = myFld.Files
''________________________________________________
'''''aus Datei 1 auslesen
' For Each xlFile In Exfiles
'Prüfen auf Dateinamen
' If LCase(Right(xlFile.Name, 3)) = "xls" Then 'And Right(xlFile.Name, 1) = "a" Then
'Zuweisen der Variablen
'mit "UpdateLinks" werden Verknüpfungen aktualisiert
Set wbDataBook = Workbooks.Open("D:\Testen\" & myDat1, UpdateLinks:=3)
'Kopieren
' wbDataBook.Worksheets("Kopfdaten").Range("C21").Copy _
' Destination:=wbMainBook.Worksheets(1).Cells(iCounter, 1)
lgRow = Cells(Rows.Count, 2).End(xlUp).Row
wbDataBook.Worksheets(myName11).Range("B212:D231").Copy _
Destination:=wbMainBook.Worksheets(1).Cells(lgRow + 1, 2) 'Cells(iCounter, 2)
wbDataBook.Worksheets(myName12).Range("B212:D231").Copy _
Destination:=wbMainBook.Worksheets(1).Cells(lgRow + 21, 2) 'Cells(iCounter, 2)
wbDataBook.Worksheets(myName13).Range("B212:D231").Copy _
Destination:=wbMainBook.Worksheets(1).Cells(lgRow + 41, 2) 'Cells(iCounter, 2)
'Zeilenzähler hochsetzen
iCounter = iCounter + 1
'Geöffnete Mappe schliessen
wbDataBook.Close
'Variable leeren
Set wbDataBook = Nothing
''_______________________________________
''' aus Datei 2 auslesen
Set wbDataBook = Workbooks.Open("D:\Testen\" & myDat2, UpdateLinks:=3)
'Kopieren
' wbDataBook.Worksheets("Kopfdaten").Range("C21").Copy _
' Destination:=wbMainBook.Worksheets(1).Cells(iCounter, 1)
wbDataBook.Worksheets(myName21).Range("B212:D231").Copy _
Destination:=wbMainBook.Worksheets(1).Cells(lgRow + 61, 2) 'Cells(iCounter, 2)
wbDataBook.Worksheets(myName22).Range("B212:D231").Copy _
Destination:=wbMainBook.Worksheets(1).Cells(lgRow + 81, 2) 'Cells(iCounter, 2)
wbDataBook.Worksheets(myName23).Range("B212:D231").Copy _
Destination:=wbMainBook.Worksheets(1).Cells(lgRow + 101, 2) 'Cells(iCounter, 2)
'Zeilenzähler hochsetzen
iCounter = iCounter + 1
'Geöffnete Mappe schliessen
wbDataBook.Close
'Variable leeren
Set wbDataBook = Nothing
' End If
' Next
'Speichert die Zusammengefasste Tabelle
wbMainBook.SaveAs "D:\Testen\All_Data.xls"
'Variable leeren
Set wbMainBook = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Besten Dank für eine Hilfe!
mfg
Private Tippgemeinschaft für Lotto oder KENO: http://www.kenostrategen.de