Lieber Sdeluxe,
also wirklich prickelnd informativ war auch deine letzte Antwort nicht.
Egal, eine einfache Testumgebung:
Datendatei(en) - Spalte C mit x bis 5000+/-x Zahlenwerten
ditto - Spalte B1 mit 1. Kriterium (hier eine Maximalvorgabe)
ditto - Spalte B2 mit 1. Kriterium (hier eine Minimalvorgabe)
ditto - Spalte B3 mit 2. Kriterium (hier eine Maximalvorgabe)
ditto - Spalte B4 mit 2. Kriterium (hier eine Minimalvorgabe)
Aufgabe:
Liste alle Dateien und schreibe die Dateinamen in Spalte A untereinander
dazu die Ergebnisse der MAX Funktion der Zahlenwerte jeder Datei
- und zwar nur innerhalb der Bandbreite Kriterium 1 bzw. 2
jetzt kannste den Code in ein leeres Workbook packen, den Pfad und
die Dateimaske anpassen
Was sich wirklich abspielen soll?
Dazu müsste " Function TestModul2a()" angepasst werden!
ABER, sry - bei deinen Erläuterungen bleibt das für mich "Schleierfahndung"!
Option Explicit
Sub TestModul1()
' ACHTUNG Microsoft Scripting Runtime in VBA-Editor/Extras/Verweise einbinden
'
' - erstelle eine sortierte Liste
' hier Tabelle "Ergebnisse" - Spalte A
'
'****************************************************
' hier die Voreinstellungen - anpassen!
Const LW_START As String = "E:\Temp" 'Startlaufwerk
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: 'errorless
'Liste abarbeiten
Call TestModul2
Case Is = 9: 'Table
Sheets.Add After:=Worksheets(Sheets.Count)
ActiveSheet.Name = "Ergebnisse"
Resume
Case Is = 76: 'FSO
Call MsgBox("Voreinstellungen Pfad?", vbCritical, "Abbruch")
'
Case Else: 'display
'
End Select
'------------------------------------------------------------------------------
'
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
Application.ScreenUpdating = True
'
End Sub
'
'
Sub TestModul2()
'**********************************************************************************
' ACHTUNG
'**********************************************************************************
' ggf. können Einschränkungen am installierten Office den OLEDB-Zugriff verhindern
' - hier getestet unter Excel Version 15.0 = Excel 2013
' - Verweise im VBA Editor beachten
' ggf. AccessDatabaseEngine passend zum Windows Betreibmichsystem
' http://www.microsoft.com/de-de/download/details.aspx?id=13255
'**********************************************************************************
'
' - Schleife über die Liste
' - Abfragestring standard
Const SEL_FROM As String = "SELECT * FROM "
' - Objektdeklaration
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
'erster Tabellenname
Set oRS = oConn.OpenSchema(20)
sSQL = SEL_FROM & Chr(91) & oRS.Fields(2).Value & Chr(93)
Set oRS = Nothing
'die Daten
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
'
'jetzt die Auswertung
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: 'errorless
Case Is = 9: 'Table
Sheets.Add After:=Worksheets(Sheets.Count)
ActiveSheet.Name = "Temp"
Resume
Case Else: 'display
End Select
'------------------------------------------------------------------------------
End Sub
'
'
Function TestModul2a() As Variant
' - im temporären Arbeitsblatt mit Code die gewünschten Matrixformeln einfügen
' - Ergebnisse in das Hauptarbeitsblatt übertragen
' - aktive Tabelle ist IMMER noch "Temp"
'
' Voreinstellungen (wegen nicht bekannter Anforderungen als einfaches Beispiel):
' Spalte B enthält Zahlenreihen
' Spalte A je einen Maximal/Minimalwert (A1/A2)
' Spalte A je einen Maximal/Minimalwert (A3/A4)
' Regelformel
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))"
'
' hier 2 Regeln, daher
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")
'Spaltenlänge B
Set Rng = Range(.Cells(1, 2), .Cells(Rows.Count, 2).End(xlUp))
lngRows = Rng.Cells.Count
'Formel Zelle darunter
Set Rng = Rng.Cells(Rng.Cells.Count).Offset(1)
'Wertetausch absolut
strFormula = Replace(RULE_01, "5000", Format(lngRows, "0"))
'jetzt die Bezüge
strFormula = Replace(strFormula, "4999", Format(lngRows - 1, "0"))
Rng.FormulaArray = strFormula
.Calculate
myArr(1) = Rng.Value
'ditto
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
|