|
Dann doch besser so:
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
'Pfad
strPfad = "E:\VBA\" 'anpassen
'Filename
strFileName = "Mappe2.xlsx" 'ditto
'Blattname
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
'Bereich A2 - An
With ThisWorkbook.Sheets("Artikelstammdaten")
'Array auswerten
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
|