level 6
Dim strFileName As String
Dim strsql As String
Dim lngN As Long
Dim lngRows As Long
Dim lngRowt As Long
Dim lngErr As Long
Dim strmsg As String
Dim blnReplace As Boolean
Dim blnErrMark As Boolean
Dim rst As Object 'DAO.Recordset
Dim objApp As Object 'Excel.Application
Dim objBook As Object 'Excel.Workbook
'使用文件对话框取得文件名
With FileDialog(3)
.InitialFileName = CurrentProject.Path
.Filters.Clear
.Filters.Add "Microsoft Excel", "*.xls"
.AllowMultiSelect = False
If .Show Then strFileName = .SelectedItems(1)
End With
'打开Excel文件
Set objApp = CreateObject("Excel.Application") ' New Excel.Application
Set objBook = objApp.Workbooks.Open(strFileName, , True)
'因为这里未指定工作表名称,所以数据必须放在第1个工作表
objBook.Worksheets(1).Select
With objApp
'根据第一列的列标题判断Excel中的数据是否能和表中的字段对应
If .Range("A1") <> "患者ID" Then
MsgBox "A:列名必须为-患者ID"
objApp.Quit
SysCmd acSysCmdRemoveMeter
DoCmd.Hourglass False
Set rst = Nothing
Set objApp = Nothing
Set objBook = Nothing
Exit Sub
End If
'因为数据是从第2行开始,所以先将计数器初始化为2,错误计数器初始化为0,实际行数初始化(去除ID为空的行)为0
lngN = 2
lngErr = 0 '相对行数,导入时此行号实时变化
lngRowt = 0 '实际行数,Excel中的行号
'打开记录集,用来录入记录
Set rst = CurrentDb.OpenRecordset("test", , 8) 'dbAppendOnly=8
'获取Excel中的记录行数
.Range("A1").Select
.ActiveCell.SpecialCells(11).Select 'xlCellTypeLastCell=11
lngRows = .ActiveCell.Row
'在状态栏中创建进度条
SysCmd acSysCmdInitMeter, "正在导入数据...", lngRows
Do Until .Range("A" & lngN) = ""
'更新进度条
SysCmd acSysCmdUpdateMeter, lngN
rst.AddNew
'数据有效性验证
If Trim(.Range("A" & lngN)) = "" Then
blnErrMark = True
objApp.Range("CA" & lngN) = "#3022 患者ID 不允许为空。"
lngErr = lngErr + 1
'验证通过后将Excel中的数据赋值给Access
'因为Excel的单元格如果没有数据读取到的是空字符串,而我们需要的是空值(Null),所以这里需要转换一下
rst!患者ID = IIf(Trim(.Range("A" & lngN)) = "", Null, Trim(.Range("A" & lngN)))
'判断是否覆盖
'覆盖-是,则删除Access原数据后重新插入
If blnReplace Then
CurrentDb.Execute "DELETE FROM test WHERE 患者ID='" & objApp.Range("A" & lngN) & "'"
rst.Update
objApp.Rows(lngN & ":" & lngN).Select
objApp.selection.Delete
objBook.Saved = True
lngN = lngN - 1
'覆盖-否,则删除Access原数据后重新插入
ElseIf DLookup("[患者ID]", "test", "患者ID = '" & objApp.Range("A" & lngN) & "'") Then
'否则将错误信息写入到Excel数据的右边第1个空列
blnErrMark = True
objApp.Range("CA" & lngN) = "#3022 该记录已存在,未被导入。"
lngErr = lngErr + 1
'然后恢复到NextRow标签处
Else
rst.Update
objApp.Rows(lngN & ":" & lngN).Select
objApp.selection.Delete
objBook.Saved = True
lngN = lngN - 1
End If
End If
NextRow:
lngN = lngN + 1
lngRowt = lngRowt + 1
Loop
rst.Close
End With
strmsg = "数据导入完成!共 "
If blnErrMark Then
strmsg = strmsg & lngRowt - lngErr & "条数据" & vbCrLf & _
"有" & lngErr & "条数据未能被导入,点“确定”查看具体情况。"
Else
strmsg = strmsg & lngRowt & "条数据"
End If
SysCmd acSysCmdSetStatus, "导入完成!"
MsgBox strmsg, vbInformation, "提示"
'如果导入过程中产生了错误,则显示Excel以便查看那些未能导入的记录的出错原因
If blnErrMark Then
objApp.Range("CA1").Select
'设置Saved属性为True,关闭时不保存写入的错误信息
objBook.Saved = True
objApp.Visible = True
End If
Exit_cmdImportFromExcel_Click:
'只有当导入过程中没有产生错误时才自动关闭Excel
If Not blnErrMark Then
If Not objApp Is Nothing Then objApp.Quit
End If
'销毁进度条
SysCmd acSysCmdRemoveMeter
'恢复光标
DoCmd.Hourglass False
Set rst = Nothing
Set objApp = Nothing
Set objBook = Nothing
Exit Sub
End Sub
2016年05月05日 05点05分