Daten aus Dateien auslesen

Hallo Ihr Götter und Göttinnen des VBA,
ich habe ein Thema, bei dem ich nicht weiterkomme.
Grundsätzlich muss ich in einer Übersichts-Exceldatei Daten aus anderen, nicht geöffneten Dateien, auslesen.
In der Übersichtsdatei befindet sich in Spalte A die jeweilige ID, welche auch auf den jeweiligen Dateinamen verweist, aus dem ausgelesen werden soll. Dort wiederum soll in Spalte A nach den Nummern 1060, 1065 und 1100 gesucht werden (befinden sich nicht immer in der selben Zeile). In der Zeile, in der sich die Nummer befinden, soll nun Spalte D und I übertragen werden. Also insgesamt 6 Werte pro Datei.
Das soll nun für alle IDs geschehen, für die entsprechende Dateien vorhanden sind.
Ich habe zur Veranschaulichung mal die Übersichtsdatei + 2 Datendateien mitgeschickt.
Dateiname: Übersicht.xlsx https://www.herber.de/bbs/user/131068.xlsx
Dateiname: 4.xlsx https://www.herber.de/bbs/user/131069.xlsx
Dateiname: 6.xlsx https://www.herber.de/bbs/user/131070.xlsx
Vielen Dank für Eure Hilfe!
Chris

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub t() Dim xl As Object, wb As Workbook, Counter As Long pfad = ThisWorkbook.Path & "\" Set xl = CreateObject("excel.application") ' für alle ID's aus Spalte A For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next ' MsgBox pfad & Cells(i, 1) & ".xlsx" Set wb = xl.Workbooks.Open(Filename:=pfad & Cells(i, 1) & ".xlsx") Set ws = wb.Sheets(1) lz = ws.Cells(Rows.Count, 1).End(xlUp).Row For ii = 2 To lz If ws.Cells(ii, 1) = 1060 Then Cells(i, 4) = ws.Cells(ii, 4) Cells(i, 5) = ws.Cells(ii, 9) Exit for End If Next ii wb.Close False Set wb = Nothing Next i Set xl = Nothing xl.Quit End Sub

anbei mal ein weiterer Ansatz für alle Spalten, Code einfach in ein Modul und den Blattnamen aus deiner Datei anpassen:

Sub t2()
Dim xl As Object, wb As Workbook
Dim pfad As String
Dim i As Long, ii As Long, lz As Long, lsp As Long
Dim myws As Worksheet
'Blattname evtl. anpassen
Set myws = ActiveWorkbook.Sheets("Sheet1")
pfad = ThisWorkbook.Path & "\"
Set xl = CreateObject("excel.application")
' für alle ID's aus Spalte A
For i = 3 To myws.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set wb = xl.Workbooks.Open(Filename:=pfad & myws.Cells(i, 1) & ".xlsx")
Set ws = wb.Sheets(1)
lz = ws.Cells(Rows.Count, 1).End(xlUp).Row
lsp = ws.Cells(1, Columns.Count).End(xlToLeft).Column
' für alle Spalten der Zeile 1 im 2er-step
For sp = 4 To lsp Step 2
For ii = 2 To lz
If ws.Cells(ii, 1) = myws.Cells(1, sp) Then
myws.Cells(i, sp) = ws.Cells(ii, 4)
myws.Cells(i, sp + 1) = ws.Cells(ii, 9)
End If
Next ii
Next sp
wb.Close False
Set wb = Nothing
Next i
Set xl = Nothing
xl.Quit
End Sub

gruss
ede

Sub t2() Dim xl As Object, wb As Workbook Dim pfad As String Dim i As Long, ii As Long, lz As Long, lsp As Long Dim myws As Worksheet 'Blattname evtl. anpassen Set myws = ActiveWorkbook.Sheets("Sheet1") pfad = ThisWorkbook.Path & "\" Set xl = CreateObject("excel.application") lsp = myws.Cells(1, Columns.Count).End(xlToLeft).Column 'letzte Spalte in 'Übersicht' ' für alle ID's aus Spalte A For i = 3 To myws.Cells(Rows.Count, 1).End(xlUp).Row On Error Resume Next Set wb = xl.Workbooks.Open(Filename:=pfad & myws.Cells(i, 1) & ".xlsx") Set ws = wb.Sheets(1) lz = ws.Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile in akt. DAtendatei ' für alle Spalten der Zeile 1 im 2er-step For sp = 4 To lsp Step 2 For ii = 3 To lz If ws.Cells(ii, 1) = myws.Cells(1, sp) Then myws.Cells(i, sp) = ws.Cells(ii, 4) myws.Cells(i, sp + 1) = ws.Cells(ii, 9) End If Next ii Next sp wb.Close False Set wb = Nothing Next i Set xl = Nothing xl.Quit End Sub

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

334 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten aus Dateien auslesen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

334 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread