AW: Automatisierter Datenimport
21.01.2019 19:02:36
Sepp
Hallo Henning,
ich hab jetzt einfach mal angenommen, dass die dateien nach dem Schema 'JJJJMMTT.xls*' benannt sind.
Modul Modul1
Option Explicit
Sub importData()
Dim strDate As String
Dim strFile As String
Dim strFormula As String
Dim strPath As String
Dim varRef As Variant
Dim lngFirst As Long
Dim lngIndex As Long
Dim lngNext As Long
Const conPATH_NAME As String = "D:\Downloads\Forum" 'Pfad - Anpassen!
Const conTAB_NAME As String = "Tabelle1" 'Tabellenname - Anpassen!
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
varRef = Array("B9", "B10", "B11", "B12") 'Auszulesende Zellen.
With Tabelle1
strPath = conPATH_NAME & IIf(Right(conPATH_NAME, 1) = "\", "", "\")
lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
lngFirst = lngNext
strFile = Dir(strPath & "*.xls*", vbNormal)
Do While Len(strFile)
If strFile Like "########.*" Then
strDate = Mid(strFile, 7, 2) & "." & Mid(strFile, 5, 2) & "." & Left(strFile, 4)
If IsDate(strDate) Then
If IsError(Application.Match(CLng(CDate(strDate)), .Columns(1), 0)) Then
.Cells(lngNext, 1) = CDate(strDate)
strFormula = "='" & strPath & "[" & strFile & "]" & conTAB_NAME & "'!"
For lngIndex = 0 To Ubound(varRef)
.Cells(lngNext, lngIndex + 2).Formula = strFormula & varRef(lngIndex)
Next
lngNext = lngNext + 1
End If
End If
End If
strFile = Dir
Loop
If lngNext > lngFirst Then
With .Range(.Cells(lngFirst, 1), .Cells(lngNext, 5))
.Calculate
.Value = .Value
End With
End If
End With
ErrorHandler:
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With
End Sub
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0