修改导入程序，加上导入进度条，使导入更加智能。



Public Sub btnImport_Click()
    On Error Resume Next
    'ImportFromExcel "联系电话"
    'RequeryDataObject Me.sfrList
    
    On Error Resume Next
    Dim ExcelApp As Object
    Dim i As Long
    Dim Book As Object
    Dim ws As Object
    Dim Rst As DAO.Recordset
    Dim xlsPath As String
    Dim dfjs As Long
   
   DoCmd.SetWarnings False
   If MsgBox("导入前需删除原记录吗？", vbYesNo + vbInformation, "提示") = vbYes Then
        DoCmd.RunSQL "DELETE 联系电话.* FROM 联系电话;"
        RequeryDataObject Me.sfrList
   End If
   
   
   
    Dim strFilters As String
    Dim varResult  As Variant
    Dim varItem    As Variant
    strFilters = "Microsoft Excel (*.xls;*.xlsx)" & vbNullChar _
               & "*.xls;*.xlsx" & vbNullChar _
               & "文本文件 (*.txt)" & vbNullChar _
               & "*.txt" & vbNullChar
    varResult = PickFile(strFilters, "选择要导入的文件", True)
    If IsNull(varResult) Then Exit Sub
    For Each varItem In varResult
        xlsPath = varItem
    Next
    
    Set ExcelApp = CreateObject("Excel.Application")
    Set ws = ExcelApp.Workbooks.Open(xlsPath).Sheets(1)

    If ws.cells(1, 1) <> "姓名" Or ws.cells(1, 2) <> "单位" Or ws.cells(1, 3) <> "联系电话" Or ws.cells(1, 4) <> "备注" Then
        MsgBox "导入表格格式错误！" & Chr(10) & "请检查导入表格文件", vbCritical, "表格错误"
        GoTo 100
    End If


    Dim clsPB As PopupProgressBar
    Dim lngI  As Long
    Set clsPB = CreateInstance("PopupProgressBar")
    clsPB.StatusText = "正在导入..."

     For i = 1 To 60000
          If Len(ws.cells(i, 1)) = 0 Then
              GoTo 101
          End If
     Next i
        
     Dim x As Long
101  x = i - 1
     clsPB.Max = x

     
     Set Rst = CurrentDb.OpenRecordset("联系电话", dbOpenDynaset)

    i = 1
    For i = 2 To x
        Rst.AddNew
        Rst!姓名 = ws.cells(i, 1)
        Rst!单位 = ws.cells(i, 2)
        Rst!联系电话 = ws.cells(i, 3)
        Rst!备注 = ws.cells(i, 4)
        Rst.Update
        i = i + 1
        
        clsPB.Value = i
    Next i
    
    clsPB.CloseProgressBar
    Me.sfrList.Requery

    ExcelApp.Workbooks(xlsPath).Close SaveChanges:=False
    ExcelApp.Quit
    Set ExcelApp = Nothing
    Set Book = Nothing
    MsgBox "数据导入成功！", vbInformation, "提示"
    
100 ExcelApp.Workbooks(xlsPath).Close SaveChanges:=False
    ExcelApp.Quit
    Set ExcelApp = Nothing
    Set Book = Nothing
End Sub