Daten von mehreren Dateien kopieren in Liste
10.02.2019 18:37:01
mehreren
verwende folgenden Code, der auch funtkioniert, aber ich gerne ein paar Änderungen an der Ausführung hätte. Und zwar werden Daten aus Dateien im selben Ordner ausgelesen und in einer neuen Tabelle Zeilenweise aufgelistet. Jetzt ist es bei diesem Code aber so, dass die Daten als Pfade in den Zellen wiedergegeben werden z. B. ='C:\Users\One\Desktop\Excel Datenabfrage\[1.xlsx]Sheet1'!$B$3 - Ist es möglich, dass die Daten so wiedergegeben werden, wie sie an sich auch sind? Ich möchte diese Liste nach dem Auslesen bearbeiten können. Und die Performance des Codes soll dabei erhalten bleiben (funktioniert so wie er ist sehr schnell). Und die Const strSheetQ As String = "Sheet1" soll immer nur das erste Sheet ansprechen, wenn es möglich ist.
Danke im Voraus für eure Hilfe.
Option Explicit
Const strSheetQ As String = "Sheet1" ' Die Tabelle wird ausgelesen
Const strSheetZ As String = "Sheet1" ' Die Tabelle in dieser Datei
Dim ZielRow As Long, fe As Integer ' übergabe an dirInfo Programm
Sub Zellen_aus_Dateien_auslesen()
Dim stCalc As XlCalculationState
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
stCalc = .Calculation
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
'Tabelleninhalt löschen und aktuellsten Stand auflisten
ThisWorkbook.Worksheets(strSheetZ).Cells.ClearContents
ZielRow = 4: fe = 0: Err = Empty '1.Zeile zum auflisten
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path ' Datei im gleichen Ordner wie Auswertungsdateien
Set objDir = objFSO.GetFolder(strDir)
dirInfo objDir, "*.xlsx", False ' Dateityp, der ausgelesen wird / Mit Unterordner (False oder _
True)
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
If Err > 0 Then MsgBox fe & " Fehler aufgetreten"
End Sub
Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim objWorkbook As Workbook
Dim strFormula As String
Dim lngLastRow As Long
Dim varTMP As Variant
Dim Formel As String
On Error GoTo Fehler
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name ThisWorkbook.Name Then
With ThisWorkbook.Worksheets(strSheetZ)
Formel = Mid(varTMP.Path, 1, InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" 'Formel Quelle in allen Zellen gleich
'B3, D3, F3, B6, D6, F6 Zellen in Formel einsetzen!
.Cells(ZielRow, 1).Formula = "='" & Formel & "$B$3"
.Cells(ZielRow, 2).Formula = "='" & Formel & "$D$3"
.Cells(ZielRow, 3).Formula = "='" & Formel & "$F$3"
.Cells(ZielRow, 4).Formula = "='" & Formel & "$B$6"
.Cells(ZielRow, 5).Formula = "='" & Formel & "$D$6"
.Cells(ZielRow, 6).Formula = "='" & Formel & "$F$6"
ZielRow = ZielRow + 1 'Nächste Zeile
End With
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName
Next varTMP
End If
Set objWorkbook = Nothing
Exit Sub
Fehler: fe = fe + 1: Resume Next
End Sub