Sub divWerteHolen()
Dim strPfad As String
Dim strFileName As String
Dim strSheetName As String
Dim oConn As Object
Dim oRs As Object
Dim sSQL As String
Dim arrWerte()
Dim ax As Long
Dim c As Range
strPfad = "E:\VBA\"
strFileName = "Mappe2.xlsx"
strSheetName = "Sheet1"
sSQL = "SELECT * FROM " & Chr(91) & strSheetName & "$C1:K" & Chr(93)
Set oConn = CreateObject("ADODB.Connection")
Set oRs = CreateObject("ADODB.Recordset")
With oConn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & _
strPfad & strFileName & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"""
.Open
End With
oRs.Open sSQL, oConn, 3, 1, 1
If Not oRs.EOF Then
arrWerte = oRs.GetRows
Else
Call MsgBox("keine Daten in " & strSheetName, vbExclamation, "Abbruch")
Exit Sub
End If
Set oRs = Nothing
Set oConn = Nothing
With ThisWorkbook.Sheets("Artikelstammdaten")
For ax = LBound(arrWerte, 2) To UBound(arrWerte, 2)
Set c = .Columns(1).Find(What:=arrWerte(0, ax), LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
c.Offset(, 2).Value = arrWerte(8, ax)
End If
Next ax
End With
End Sub