求助 excel连接access数据库

gongaru

各位好

尝试往数据库里面倒入数据，提示错误：在对应所需名称或叙述中未找到项目
不确定数据库是否正常连接。请大神指点。
谢谢！！

gongaru

Sub DataImport()
On Error Resume Next
'Open the original data
Dim tmpBook As Workbook, tmpSheet As Worksheet
'Set tmpBook = Excel.ActiveWorkbook
'Set tmpSheet = tmpBook.Sheets(1)

Dim openFilePN As String
    openFilePN = Excel.Application.GetOpenFilename("All files (*.*),*.*", , "Select the workbook!")
    Set tmpBook = Excel.Workbooks.Open(openFilePN)
    'Set tmpSheet = tmpBook.Sheets(1)
    'Set tmpBook = Excel.ActiveWorkbook
    Set tmpSheet = tmpBook.Sheets(1)

Dim i, j, k, n, m As Integer

Dim cnn As ADODB.Connection
Dim rs As ADODB.Recordset

Set cnn = New ADODB.Connection
Set rs = New ADODB.Recordset

Dim SQL As String
Dim myPath As String
Dim myTable As String

myPath = "C:\Users\0000135401\Desktop\TEGE yoursony" & "GE DB.accdb"
myTable = "原紙データ"

SQL = "select * from" & myTable
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & myPath & ";Jet OLEDB:Database Password=ge" 'Open DB
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic

m = rs.RecordCount
   
For i = 2 To tmpSheet.Range("B65536").End(xlUp).Row
            rs.AddNew
            
            rs.Fields(0).Value = tmpSheet.Cells(i, 9).Value '大連処理開始日
            rs.Fields(1).Value = tmpSheet.Cells(i, 11).Value '会社名
            rs.Fields(2).Value = tmpSheet.Cells(i, 12).Value '事前申請（伝票区分）
            rs.Fields(3).Value = tmpSheet.Cells(i, 8).Value 'レポートID
            rs.Fields(4).Value = TD '入力担当
            rs.Fields(6).Value = "未審査" '一次審査結果
            rs.Fields(9).Value = "未審査" '二次審査結果
            rs.Fields(14).Value = tmpSheet.Cells(i, 13).Value '領収書が必須
            rs.Fields(15).Value = tmpSheet.Cells(i, 51).Value '入力数
            rs.Fields(16).Value = tmpSheet.Cells(i, 2).Value '申請者提出日
            rs.Fields(17).Value = tmpSheet.Cells(i, 56).Value '従業員 ID
            rs.Fields(18).Value = tmpSheet.Cells(i, 7).Value 'レポート総計
            rs.Fields(19).Value = tmpSheet.Cells(i, 10).Value '担当経理
            
        
                    
            rs.Update
        Next
   
   
    tmpSheet.Range("AE1:AG65536").ClearContents
    tmpBook.Save
    tmpBook.Close

    m = rs.RecordCount - m
    MsgBox m & "件 import to Acess sucessfully"
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
   
End Sub

gmts

Sub 导入第1次大考名单到表格()
  On Error GoTo ooo
    Dim myData As String, myTable As String, SQL As String
    Dim cnn As Object
    Dim rs As Object
    Dim i As Integer
     Sheets("录入成绩").Select
'    清除表格线
    ActiveSheet.Range("a4, d3000").Delete
    Set cnn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    myData = ThisWorkbook.Path & "\学生成绩库.mdb"
    myTable = "第1次大考成绩"
    With cnn
        .Provider = "microsoft.jet.oledb.4.0"
        .Open myData
    End With
     Sheets("录入成绩").Range("A4:m3000").Delete     '清除现有表中A列至Z列前1000行的所有内容
     Sheets("录入成绩").Range("A4:d3000").ClearContents     '清除现有表中A列至Z列前1000行的所有内容
    SQL = "select 班别,学号,姓名 from " & myTable & " order by 学号"
    rs.Open SQL, cnn, 3, 3
    If rs.RecordCount > 0 Then
        For i = 1 To rs.Fields.Count
            Cells(3, i) = rs.Fields(i - 1).Name
        Next i
        With Range(Cells(3, 1), Cells(3, rs.Fields.Count))
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
        Range("A4").CopyFromRecordset rs
        ActiveSheet.Range("a3,m3000").Font.Size = 10
    End If
      With Sheets("录入成绩")
       .CommandButton1.Visible = True
       .CommandButton2.Visible = False
       .CommandButton3.Visible = False
      End With
    MsgBox "数据库中的记录数为：" & rs.RecordCount
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
Exit Sub
ooo:
   MsgBox "对不起，操作错误，不能够为您提供服务！"
End Sub

gmts

仅供参考，希望对你有启发

gongaru

gmts 发表于 2016-12-19 17:18
仅供参考，希望对你有启发

?没有看到附件或者提示之类的呀  麻烦再发一次好么

microyip

本身都没附件给别人，还要求别人给附件，是不是有点可笑

gongaru

sorry啊  没看到之前的代码