Daten aus mehreren XLS auslesen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub ReadData() Dim objCell As Range Dim objWorkbook As Workbook Dim objWorksheet As Worksheet For Each objCell In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)) Application.StatusBar = " " & CStr(objCell.Row) If Application.CountA(objCell.EntireColumn) = 1 Then If Dir$(PathName:=objCell.Text) vbNullString Then Set objWorkbook = GetObject(PathName:=objCell.Text) For Each objWorksheet In objWorkbook.Worksheets With objWorksheet Select Case .Name Case "Lötseite" objCell.Offset(0, 1).Value = .Range("F12").Value objCell.Offset(0, 2).Value = .Range("F14").Value objCell.Offset(0, 3).Value = .Range("F16").Value objCell.Offset(0, 4).Value = .Range("E18").Value objCell.Offset(0, 5).Value = .Range("F23").Value objCell.Offset(0, 6).Value = .Range("K22").Value objCell.Offset(0, 7).Value = .Range("K23").Value objCell.Offset(0, 8).Value = .Range("K24").Value objCell.Offset(0, 9).Value = .Range("H27").Value objCell.Offset(0, 10).Value = .Range("F22").Value objCell.Offset(0, 11).Value = .Range("F20").Value objCell.Offset(0, 12).Value = .Range("K29").Value objCell.Offset(0, 13).Value = .Range("H32").Value Case "Bauteilseite" objCell.Offset(0, 14).Value = .Range("F12").Value objCell.Offset(0, 15).Value = .Range("F14").Value objCell.Offset(0, 16).Value = .Range("F16").Value objCell.Offset(0, 17).Value = .Range("E18").Value objCell.Offset(0, 18).Value = .Range("F23").Value objCell.Offset(0, 19).Value = .Range("K22").Value objCell.Offset(0, 20).Value = .Range("K23").Value objCell.Offset(0, 21).Value = .Range("K24").Value objCell.Offset(0, 22).Value = .Range("H27").Value objCell.Offset(0, 23).Value = .Range("F22").Value objCell.Offset(0, 24).Value = .Range("F20").Value objCell.Offset(0, 25).Value = .Range("K29").Value objCell.Offset(0, 26).Value = .Range("H32").Value End Select End With Next Call objWorkbook.Close(SaveChanges:=False) Set objWorkbook = Nothing End If End If Next Application.StatusBar = False Call MsgBox("Fertig", vbInformation, "Information") End Sub

Hallo Stefan,
damit prüfe ich ob in der Zeile nur der Dateiname steht. Damit du beim Neustart nicht alle schon erledigten Dateien neu einlesen musst.
Ich habe es jetzt geändert, es wird nur der Bereich geprüft (Spalte A - AA) in welche die Daten eingetragen werden, ob das schon was drinsteht.


Option Explicit
Public Sub ReadData()
Dim objCell As Range
Dim objWorkbook As Workbook
Dim objWorksheet As Worksheet
Application.EnableEvents = False
For Each objCell In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
Application.StatusBar = "   " & CStr(objCell.Row)
DoEvents
If Application.CountA(objCell.Resize(1, 27)) = 1 Then
If Dir$(PathName:=objCell.Text)  vbNullString Then
Set objWorkbook = GetObject(PathName:=objCell.Text)
For Each objWorksheet In objWorkbook.Worksheets
With objWorksheet
Select Case .Name
Case "Lötseite"
objCell.Offset(0, 1).Value = .Range("F12").Value
objCell.Offset(0, 2).Value = .Range("F14").Value
objCell.Offset(0, 3).Value = .Range("F16").Value
objCell.Offset(0, 4).Value = .Range("E18").Value
objCell.Offset(0, 5).Value = .Range("F23").Value
objCell.Offset(0, 6).Value = .Range("K22").Value
objCell.Offset(0, 7).Value = .Range("K23").Value
objCell.Offset(0, 8).Value = .Range("K24").Value
objCell.Offset(0, 9).Value = .Range("H27").Value
objCell.Offset(0, 10).Value = .Range("F22").Value
objCell.Offset(0, 11).Value = .Range("F20").Value
objCell.Offset(0, 12).Value = .Range("K29").Value
objCell.Offset(0, 13).Value = .Range("H32").Value
Case "Bauteilseite"
objCell.Offset(0, 14).Value = .Range("F12").Value
objCell.Offset(0, 15).Value = .Range("F14").Value
objCell.Offset(0, 16).Value = .Range("F16").Value
objCell.Offset(0, 17).Value = .Range("E18").Value
objCell.Offset(0, 18).Value = .Range("F23").Value
objCell.Offset(0, 19).Value = .Range("K22").Value
objCell.Offset(0, 20).Value = .Range("K23").Value
objCell.Offset(0, 21).Value = .Range("K24").Value
objCell.Offset(0, 22).Value = .Range("H27").Value
objCell.Offset(0, 23).Value = .Range("F22").Value
objCell.Offset(0, 24).Value = .Range("F20").Value
objCell.Offset(0, 25).Value = .Range("K29").Value
objCell.Offset(0, 26).Value = .Range("H32").Value
End Select
End With
Next
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
End If
End If
Next
With Application
.StatusBar = False
.EnableEvents = True
End With
Call MsgBox("Fertig", vbInformation, "Information")
End Sub

Gruß
Nepumuk

Public Sub ReadData() Dim Z As Range Dim Pfad As String Dim DName As String Dim i As Long Dim Quell Application.EnableEvents = False Quell = Split(";F12;F14;F16;E18;F23;K22;K23;K24;H27;F22;F20;K29;H32", ";") For Each Z In Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)) Application.StatusBar = " " & CStr(Z.Row) DoEvents If Application.CountA(Z.Resize(1, 27)) = 1 Then If Dir$(PathName:=Z.Text) vbNullString Then Pfad = Mid(Z.Text, 1, InStrRev(Z.Text, "\")) DName = Mid(Z.Text, InStrRev(Z.Text, "\") + 1) Set wB = GetObject(PathName:=Z.Text) For i = 1 To 13 Z.Offset(0, i).Formula = "='" & Pfad & "[" & DName & "]Lötseite'!" & Quell(i) Z.Offset(0, i + 13).Formula = "='" & Pfad & "[" & DName & "]Bauteilseite'!" & Quell(i) Next Z.EntireRow.Calculate Z.Range("B1:AA1") = Z.Range("B1:AA1").Value 'Formel durch Wert ersetzen Z.Range("B1:AA1").SpecialCells(xlCellTypeConstants, 16).ClearContents 'Zelle mit Fehler leeren End If End If Next Application.StatusBar = False Application.EnableEvents = True Call MsgBox("Fertig", vbInformation, "Information") End Sub

Hi
Du könntest da auch mal folgendes probieren:
- in Spalte A steht der Pfad
- in Spalte B steht der Dateiname
- in Zeile 1 stehen ab Spalte C die zelladresse, die du auslesen willst.
- Zelle C2 kommt diese Formel, welche die eigentliche ausleseformel zunächst als Text erzeugt:


="='"&$A2&"["&$B2&"]Lötseite'!"&C$1

Die Zelle C2 kopierst du dann nach unten und nach rechts, soweit wie benötigt.
Den ganzen Block kopierst du dann und fügst ihn als Text ein.
Jetzt hast du alle Formeln mit externen Bezug, die aber noch Text sind und nicht berechnet werden.
Um sie in Formeln umzuwandeln und die Werte zu bekommen, kannst du in diesem Zellbereich einmal das ERSETZTEN ausführen und "=" durch "=" zu ersetzten (es klingt widersinnig, etwas durch das gleiche zu ersetzten, aber es veranlasst Excel, den Text in Formeln zu wandeln)
Zum Schluss solltest du den Bereich dann nochmal kopieren und als Wert einfügen, um die Externen Zellbezüge zu eliminieren.
Funktioniert im Prinzip auch ohne Makro, nur würde ich das nicht mit allen 15.000 Zeilen gleichzeitig machen.
Hier könntest du dir ein Makro schreiben, dass die Aktionen
- "=" durch "=" ersetzen und in. Werte wandeln
Immer für einen bestimmten Zellbereich durchführt (die optimale Größe musst du ausprobieren) und dann zur Sicherheit zwischenspeichert, also vielleicht so:


For z =  2 to 15000 step 10
With Cells(z, 3).resize(10, 26)
.Replache "=", "=", xlpart
.Formula = .Value
Ende with
Thisworkbook.Save
Next

Problematisch könnte höchsten sein, wenn Blätter nicht vorhanden sind, denn Externe Zellbezüge, die nicht funktionieren, kann Excel nicht sauber verarbeiten, aber auch nicht ignorieren, FAS könnte ein Problem hierbei werden.
Gruß Daniel

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

322 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Daten aus mehreren XLS auslesen

25 Beiträge zum Forumthread Beiträge zu diesem Forumthread

322 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

25
Beiträge zum Forumthread

Beiträge zu diesem Forumthread