ник: nika
Привет спасибо за предложенное решение Пока не пробовала но всё равно спасибо. Я тут кое что другое нарыла. Почемуто не работает хотя ошибок не даёт.
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