Excel数据导入Access，导入不完全 ，请老师指点

[plx2425]

将Excell中的数据导入到Access中。但有时发现只能导入部分数据，比如有300多条数据有时只能导入100多点，有时候又能全部导入，特别是第一次导入的可以全部导入...不知道哪里需要完善下，是VB代码的问题呢还是access的问题啊。请老师帮忙看看呢...
Private Sub 收入_Click()
Conn = "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=6109003091;Data Source=" + App.Path + "\四知.mdb;Persist Security Info=False"
Adodc1.ConnectionString = Conn
Adodc1.RecordSource = "select 档案号 AS 档案号,姓名 AS 姓名,支出摘要 AS 支出摘要,金额 AS 金额,时间 AS 时间,结算 AS 结算 from 支出明细表 "


On Error Resume Next

Dim fileadd As String
CommonDialog1.ShowOpen
CommonDialog1.Filter = "" '选择你要的文件
fileadd = CommonDialog1.FileName
If fileadd = "" Then Exit Sub
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open(fileadd) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False ' = True '设置EXCEL对象可见（或不可见）
Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
For r = 1 To 99999 '行循环
If LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 1))) <> "" Then
Adodc1.Refresh
Adodc1.Recordset.Find "档案号='" & LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 1))) & "'"
Adodc1.Recordset.Find "姓名='" & LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 2))) & "'"
Adodc1.Recordset.Find "支出摘要='" & LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 3))) & "'"
Adodc1.Recordset.Find "金额='" & LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 4))) & "'"
Adodc1.Recordset.Find "时间='" & LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 5))) & "'"
If Adodc1.Recordset.EOF Then
Adodc1.Recordset.AddNew
Adodc1.Recordset.Fields("档案号") = LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 1)))
Adodc1.Recordset.Fields("姓名") = LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 2)))
Adodc1.Recordset.Fields("支出摘要") = LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 3)))
Adodc1.Recordset.Fields("金额") = LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 4)))
Adodc1.Recordset.Fields("时间") = LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 5)))
Adodc1.Recordset.Fields("结算") = "否"


Adodc1.Recordset.Update
DataGrid1.AllowUpdate = True

Else

End If
Else
r = 99999 + 1
End If
Next r

xlApp.DisplayAlerts = False '不进行安全提示 '
Set xlSheet = Nothing '
Set xlBook = Nothing '
xlApp.Quit '
Set xlApp = Nothing
Set DataGrid1.DataSource = Adodc1


End Sub

[threenewbee]

If LTrim(RTrim(xlBook.Worksheets(1).Cells(r, 1))) <> "" Then
这里调试下，看看是不是有空行或者某行的第一列为空

[plx2425]

没有空行啊，都有数据的

[plx2425]

自己搞定了
Dim strFieldsName As String
Dim strValue As String
Dim strSQL As String
Dim cnnADO As New ADODB.Connection

Dim fileadd As String
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object

Dim r As Long

cnnADO.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=6109003091;Data Source=" + App.Path + "\四知.mdb;Persist Security Info=False"

cnnADO.Open
CommonDialog1.ShowOpen
CommonDialog1.Filter = "" '选择你要的文件
fileadd = CommonDialog1.FileName
If fileadd = "" Then Exit Sub
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = xlApp.Workbooks.Open(fileadd) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False ' = True '设置EXCEL对象可见（或不可见）
Set xlSheet = xlBook.Worksheets(1) '设置活动工作表

r = 1
Do While (Trim(xlSheet.cells(r, 1)) <> "") Or (xlSheet.cells(r, 1) <> 0)

strValue = "'" & Trim(xlSheet.cells(r, 1)) & "','" & Trim(xlSheet.cells(r, 2)) _
& "','" & Trim(xlSheet.cells(r, 3)) & "','" & Trim(xlSheet.cells(r, 4)) _
& "','" & Trim(xlSheet.cells(r, 5)) & "','" & "Off" & "'"

strSQL = "insert into 收入明细表 ( 档案号 ,姓名 ,收入摘要 ,金额 ,时间 ,结算) values(" _
& strValue & ")"
cnnADO.Execute strSQL
r = r + 1
Loop
xlApp.DisplayAlerts = False '不进行安全提示 '
Set xlSheet = Nothing '
Set xlBook = Nothing '
xlApp.Quit '
Set xlApp = Nothing
Set DataGrid1.DataSource = Adodc1


cnnADO.Close

Set cnnADO = Nothing



End Sub