Code:
Option Explicit
Const strSheetQ As String = "ComTool" ' Die Tabelle wird ausgelesen
Const strSheetZ As String = "Sheet1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "M6" ' Die Zelle wird ausgelesen
Const strCellQ2 As String = "D4"
Const strCellQ3 As String = "D5"
Const strCellQ4 As String = "G5"
Const strCellQ5 As String = "H115"
Const strCellQ6 As String = "K115"
Const strCellQ7 As String = "Q115"
Public Sub Files_Read()
Dim stCalc As Integer
Dim strDir As String
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
With Application
.ScreenUpdating = False
.AskToUpdateLinks = False
.EnableEvents = False
stCalc = .Calculation
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
Set objFSO = CreateObject("Scripting.FileSystemObject")
strDir = ThisWorkbook.Path ' Datei im gleichen Ordner wie Auswertungsdateien
Set objDir = objFSO.GetFolder(strDir)
'dirInfo objDir, "*.xls", True ' Mit Unterordner
dirInfo objDir, "*.xls"
Fin:
With Application
.ScreenUpdating = True
.AskToUpdateLinks = True
.EnableEvents = True
.Calculation = stCalc
.DisplayAlerts = True
End With
Set objDir = Nothing
Set objFSO = Nothing
End Sub
Public 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
For Each varTMP In objCurrentDir.Files
If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
With ThisWorkbook.Worksheets(strSheetZ)
lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
.Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
With .Cells(lngLastRow, 2)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ1
.Offset(0, -1).Value = varTMP.Name
End With
With .Cells(lngLastRow, 3)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ2
End With
With .Cells(lngLastRow, 4)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ3
End With
With .Cells(lngLastRow, 5)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ4
End With
With .Cells(lngLastRow, 6)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ5
End With
With .Cells(lngLastRow, 7)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ6
End With
With .Cells(lngLastRow, 8)
.Formula = "='" & Mid(varTMP.Path, 1, _
InStrRev(varTMP.Path, "\")) & "[" & _
Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
strSheetQ & "'!" & strCellQ7
End With
.UsedRange.Value = .UsedRange.Value
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
End Sub
Hallo.
Mit deiner Hilfe hätte ich einige Dateien bearbeiten können, da ich nur den Zielpfad hätte ändern müssen.
Daher vielen lieben Dank für deine Hilfe.
Da sich herausstellte, dass sich das auszulesene Formular mit der Zeit geändert hat, hätte ich den Query anpassen müssen.
Leider bin ich dort nicht ganz hintergestiegen. Zumindest nicht in der kurzen Zeit.
Hab mir nochmal Youtube Videos von Thehos, Gharani und Excelsfun angeschaut. Aber da sind die Beispiele dann doch immer sehr mustergültig. Die Videos heißen dann "cleaning messy Data". Aber die "messy Data" ist sauber in Spalten und dann doch nicht so "messy". Da wird dann nur mal eine leere Zeile entfernt, das Datumsformat angepasst und das wars.
Meine Recherche hat dann noch einen Code aus dem Jahr 2013 zum Vorschein gebracht.
Den wollte ich noch posten, falls den jemand gebrauchen kann. Muss noch mit den individuellen Tabellennamen angepasst werden und als .xls muss ggf. die Version auf .xlsx umgeschrieben werden.