Option Explicit
Sub Werteholen()
Dim obj_fso As Object
Set obj_fso = CreateObject("Scripting.FileSystemObject")
Dim rngPfadDatei As Range, rngFcnt As Range
Set rngPfadDatei = ActiveWorkbook.Sheets("Tabelle1").Range("A2:A101")
ActiveWorkbook.Sheets("Tabelle1").Range("B2:R101").Clear
For Each rngFcnt In rngPfadDatei
If obj_fso.fileExists(rngFcnt.Formula) Then
rngFcnt.Offset(0, 1).Formula = "OK"
If NurEinDatenfeld(rngFcnt.Formula, "[Tabelle4$B3:B300]", "R3", False) Then
End If
MeineAuswertung rngFcnt, "R2"
Else
rngFcnt.Offset(0, 1).Formula = "NA"
End If
Next rngFcnt
Columns("R:R").Clear
Set obj_fso = Nothing
Set obTimer = Nothing
End Sub
Private Sub MeineAuswertung(ByVal MeineDatei As Range, _
strDatenfeld As String)
Dim rngDatenfeld As Range, rngcnt As Range
Dim SucheWert As Double
On Error GoTo errorhandler
Set MeineDatei = MeineDatei.End(xlToRight).Offset(0, 1)
Set rngDatenfeld = Range(strDatenfeld)
Set rngDatenfeld = Range(rngDatenfeld, rngDatenfeld.End(xlDown))
Do While MeineDatei.Column < rngDatenfeld.Column
SucheWert = Cells(1, MeineDatei.Column)
MeineDatei.Value = WorksheetFunction.CountIf(rngDatenfeld, SucheWert)
Set MeineDatei = MeineDatei.Offset(0, 1)
Loop
On Error GoTo 0
Exit Sub
errorhandler:
MsgBox "Fehler in Auswertung " & MeineDatei.Address, vbCritical
On Error GoTo 0
End Sub
Private Function NurEinDatenfeld(ByVal strPfadDatei As String, _
ByVal strDatenBereich, ByVal strZieladresse, _
ByVal Kopf As Boolean) As Boolean
Dim oDatenfeld As Object
Dim strVerbindung As String
Dim strSQL As String
strVerbindung = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strPfadDatei & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
strSQL = "SELECT * FROM " & strDatenBereich
On Error GoTo errorhandler
Set oDatenfeld = CreateObject("ADODB.Recordset")
oDatenfeld.Open strSQL, strVerbindung, 0, 1, 1
If Not oDatenfeld.EOF Then
ActiveSheet.Range(strZieladresse).CopyFromRecordset oDatenfeld
If Not Kopf Then Range(strZieladresse).Offset(-1, 0).Value = _
oDatenfeld.Fields(0).Name
NurEinDatenfeld = True
Else
MsgBox "keine Daten in " & strPfadDatei, vbCritical
End If
errorhandler:
oDatenfeld.Close
Set oDatenfeld = Nothing
On Error GoTo 0
End Function