открыть книгу, скопировать данные в переменную, занести в базу Рекордсет - запрос на добавление....

создать связанную тбл, и запрос на добавление

Привет спасибо за предложенное решение Пока не пробовала но всё равно спасибо. Я тут кое что другое нарыла. Почемуто не работает хотя ошибок не даёт.

Public Sub GetFromExcel()
On Error GoTo er
Dim cmd As ADODB.Command
Dim obj As Object
Dim st As Variant
Dim curGrp As String
Dim i As Long
Dim rst As ADODB.Recordset
Set cmd = New ADODB.Command
'Tabelle löschen
cmd.ActiveConnection = CurrentProject.Connection
cmd.CommandText = "DROP TABLE probe"
cmd.CommandType = adCmdText
cmd.Execute 'Tabelle neu erzeugen
cmd.CommandText = "CREATE TABLE probe (Id int,Name nvarchar(255),Nummer int, Zeichen nvarchar(255))"
cmd.Execute
Set cmd = Nothing 'Zeiger auf Null setzen (zeigt nicht mehr auf ein Objekt)
Set rst = New ADODB.Recordset 'Recordset Objekt erzeugen
rst.Open "SELECT * FROM probe", CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
'Tabelle fuhlen
Set obj = GetObject("H:\excel_probe1.xls") 'Pfad zu excel Tabelle
i = 2
'st = obj.ActiveSheet.Range("a" & i & ":a" & i) curGrp = vbNullString
Do While st <> vbNullString
rst.AddNew
'If st Like "?*" Then
'If st <> curGrp Then
'curGrp = st
'End If
'i = i + 1
st = obj.ActiveSheet.Range("a" & i & ":a" & i)
If st = vbNullString Then Exit Do
'End If
'rst![NGroup] = curGrp
rst![Name] = st
rst![Nummer] = CLng(obj.ActiveSheet.Range("b" & i & ":b" & i))
rst![Zeichen] = CLng(obj.ActiveSheet.Range("c" & i & ":c" & i))
rst.Update
i = i + 1
'st = obj.ActiveSheet.Range("a" & i & ":a" & i)
Loop
Set obj = Nothing
rst.Close
Set rst = Nothing
Exit Sub
er:

Select Case Err.Number
Case -2147217865
Resume Next
Case Else
MsgBox Err.Number & vbCrLf & Err.Description
End Select
End Sub

если имя эксель файла известно и если известен диапазон ячеек, то проще (и, наверное, правильнее) это делать из аксеса