' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub import()
Dim objFSO As Object, objFolder As Object, objSub As Object, objFile As Object
Dim strPath As String, strFormula As String, strRef As String
Dim lngLast As Long, lngCol As Long
Dim CalculationMode As Long
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.EnableEvents = False
CalculationMode = .Calculation
.Calculation = xlManual
.DisplayAlerts = False
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "E:\Forum\Test\2015" 'Startverzeichnis anpassen!
.Title = "Import - Ordnerauswahl"
.ButtonName = "Import Starten"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
End If
End With
If Len(strPath) Then
With Sheets("Analyse")
With .Range(.Cells(1, 2), .Cells(1, .Columns.Count)).EntireColumn
.Clear
.ColumnWidth = 10.71
End With
lngLast = Application.Max(2, .Cells(Rows.Count, 1).End(xlUp).Row)
lngCol = 2
Set objFSO = CreateObject("Scripting.Filesystemobject")
Set objFolder = objFSO.getfolder(strPath)
For Each objSub In objFolder.SubFolders
Set objFile = objFSO.getFile(objSub.Path & "\Quelle.xlsx")
If Not objFile Is Nothing Then
strRef = "'" & objSub.Path & "\[Quelle.xlsx]Werte'!"
strFormula = "=INDEX(" & strRef & "$D:$D,MATCH(A2," & strRef & "$A:$A,0))"
With .Range(.Cells(2, lngCol), .Cells(lngLast, lngCol))
.Formula = strFormula
.Value = .Value
End With
With .Cells(1, lngCol)
.Formula = "=" & strRef & "E2"
.Value = .Value
.NumberFormat = "m/d/yyyy"
End With
lngCol = lngCol + 1
End If
Set objFile = Nothing
Next
End With
MsgBox "Daten wurden importiert!", vbInformation
End If
ErrorHandler:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'nn'" & vbLf & String(25, "") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, 81968, "VBA - Fehler in Prozedur - import", .HelpFile, .HelpContext
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalculationMode
.DisplayAlerts = True
.StatusBar = False
End With
Set objFSO = Nothing
Set objFolder = Nothing
End Sub