Option Explicit
Sub TestModul1()
Const LW_START As String = "E:\Temp"
Const NM_MASKE As String = "ANONYM-??-??-????.xlsx"
Dim oFSO As New FileSystemObject
Dim oFolder As Folder
Dim oFile As File
Dim Rng As Range
On Error GoTo TestModul1_Error
Application.ScreenUpdating = False
With Sheets("Ergebnisse")
.Activate
.Cells.Clear
Set Rng = Cells(1, 1)
Set oFolder = oFSO.GetFolder(LW_START)
For Each oFile In oFolder.Files
If oFile.Name Like NM_MASKE Then
Rng.Value = LW_START & "\" & oFile.Name
Set Rng = Rng.Offset(1)
End If
Next oFile
Columns(1).AutoFit
End With
On Error GoTo 0
TestModul1_Error:
Select Case Err.Number
Case Is = 0:
Call TestModul2
Case Is = 9:
Sheets.Add After:=Worksheets(Sheets.Count)
ActiveSheet.Name = "Ergebnisse"
Resume
Case Is = 76:
Call MsgBox("Voreinstellungen Pfad?", vbCritical, "Abbruch")
Case Else:
End Select
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
Application.ScreenUpdating = True
End Sub
Sub TestModul2()
Const SEL_FROM As String = "SELECT * FROM "
Dim oConn As Object
Dim oRS As Object
Dim sSQL As String
Dim Rng As Range
Dim arrResult() As Variant
Dim x As Long
On Error GoTo TestModul2_Error
With Sheets("Temp")
.Activate
Set Rng = Sheets("Ergebnisse").Cells(1, 1)
Do While Len(Trim(Rng.Value)) > 0
Set oConn = CreateObject("ADODB.Connection")
Set oRS = CreateObject("ADODB.Recordset")
With oConn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & Rng.Value & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"""
.Open
End With
Set oRS = oConn.OpenSchema(20)
sSQL = SEL_FROM & Chr(91) & oRS.Fields(2).Value & Chr(93)
Set oRS = Nothing
Set oRS = CreateObject("ADODB.Recordset")
oRS.Open sSQL, oConn, 3, 1, 1
If Not oRS.EOF Then
.Cells.Clear
.Cells(1, 1).CopyFromRecordset oRS
End If
arrResult = TestModul2a
For x = LBound(arrResult) To UBound(arrResult)
Rng.Offset(, x).Value = arrResult(x)
Next x
Set Rng = Rng.Offset(1)
Loop
End With
On Error GoTo 0
TestModul2_Error:
Select Case Err.Number
Case Is = 0:
Case Is = 9:
Sheets.Add After:=Worksheets(Sheets.Count)
ActiveSheet.Name = "Temp"
Resume
Case Else:
End Select
End Sub
Function TestModul2a() As Variant
Const RULE_01 = "=MAX(IF((R[-5000]C:R[-1]C<=R[-5000]C[-1])*(R[-5000]C:R[-1]C>=R[-4999]C[-1]),R[-5000]C:R[-1]C))"
Const RULE_02 = "=MAX(IF((R[-5000]C:R[-1]C<=R[-4998]C[-1])*(R[-5000]C:R[-1]C>=R[-4997]C[-1]),R[-5000]C:R[-1]C))"
Dim myArr(1 To 2)
Dim Rng As Range
Dim lngRows As Long
Dim strFormula As String
Dim strSwap As String
Application.Calculation = xlCalculationManual
With Sheets("Temp")
Set Rng = Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
lngRows = Rng.Cells.Count
Set Rng = Rng.Cells(Rng.Cells.Count).Offset(1)
strFormula = Replace(RULE_01, "5000", Format(lngRows, "0"))
strFormula = Replace(strFormula, "4999", Format(lngRows - 1, "0"))
Rng.FormulaArray = strFormula
.Calculate
myArr(1) = Rng.Value
Rng.Clear
strFormula = Replace(RULE_02, "5000", Format(lngRows, "0"))
strFormula = Replace(strFormula, "4998", Format(lngRows - 2, "0"))
strFormula = Replace(strFormula, "4997", Format(lngRows - 3, "0"))
Rng.FormulaArray = strFormula
myArr(2) = Rng.Value
.Calculate
End With
Application.Calculation = xlCalculationAutomatic
TestModul2a = myArr
End Function