Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sql As String
Dim provider As String
Dim datasource As String
Dim Irow, Icol As Integer
  Dim Irowcount, Icolcount As Integer
  Dim Fieldlen()
  Dim xlApp As excel.Application
  Dim xlBook As excel.Workbook
  Dim xlSheet As excel.Worksheet  Set xlApp = CreateObject("Excel.Application")
  Set xlBook = xlApp.Workbooks.Add
  Set xlSheet = xlBook.Worksheets(1)provider = "provider=Microsoft.jet.oledb.4.0"
datasource = "data source=" & App.Path & "\图书管理数据.mdb"
conn.Open provider & ";" & datasource
sql = "select * from 借阅信息  where 还书日期 is not null"
rs.Open sql, conn, adOpenKeyset, adLockOptimisticIf rs.RecordCount = 0 Then
    MsgBox "借阅信息为空!", vbOKOnly + vbExclamation
   rs.Close
   xlBook.Close
  Set xlApp = Nothing
  Set xlBook = Nothing
  Set xlSheet = Nothing
  Exit Sub
End If
  Irowcount = rs.RecordCount
  Icolcount = rs.Fields.Count  ReDim Fieldlen(Icolcount)
   rs.MoveFirst
   
   '设置单元格式
 xlSheet.Cells.Select
 Selection.NumberFormatLocal = "@"
 '开始插入数据
  For Irow = 1 To Irowcount + 1
   For Icol = 1 To Icolcount
          Select Case Irow
          Case 1
          xlSheet.Cells(Irow, Icol).Value = rs.Fields(Icol - 1).Name
          Case 2
        
          If IsNull(rs.Fields(Icol - 1)) = True Then
            Fieldlen(Icol) = LenB(rs.Fields(Icol - 1).Name)
          
         Else
            Fieldlen(Icol) = LenB(rs.Fields(Icol - 1))
          End If
           xlSheet.Columns(Icol).ColumnWidth = CStr(Fieldlen(Icol))
        
          xlSheet.Cells(Irow, Icol).Value = CStr(rs.Fields(Icol - 1))
        
          Case Else
          Fieldlen1 = LenB(rs.Fields(Icol - 1))
        
          If Fieldlen(Icol) < Fieldlen1 Then
          xlSheet.Columns(Icol).ColumnWidth = Fieldlen1
        
          Fieldlen(Icol) = Fieldlen1
          
          Else
           xlSheet.Columns(Icol).ColumnWidth = CStr(Fieldlen(Icol))
          End If
        
          xlSheet.Cells(Irow, Icol).Value = CStr(rs.Fields(Icol - 1) & " ")
          End Select
  Next  Next
           xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, Icol - 1)).Font.Name = "黑体"
        
 xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, Icol - 1)).Font.Bold = True
        
 xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(Irow, Icol - 1)).Borders.LineStyle = xlContinuous
 
 xlApp.Visible = True
  
  xlBook.Save
  Set xlApp = Nothing
  Set xlBook = Nothing
  Set xlSheet = Nothing
  rs.Close
Erro:
If Err.Number <> 0 Then
MsgBox "借阅信息导出失败", vbOKOnly + vbExclamation
End If导出失败后!进程就能关掉了!还有导出一次成功后,第二次就报错为变量未设置!

解决方案 »

  1.   

    加一个错误处理语句,加上一个Set XXX=Nothing语句。
      

  2.   

    Erro:
    If Err.Number <> 0 Then
    MsgBox "借阅信息导出失败", vbOKOnly + vbExclamation
    End If==>Erro:
    If Err.Number <> 0 ThenSet xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    MsgBox "借阅信息导出失败", vbOKOnly + vbExclamation
    End If
      

  3.   

    给你个片段做参考:.
    .
    .
        ' Close Excel.
        excel_app.Quit
        Set excel_app = Nothing    MsgBox "导出成功"
        
    Exit SubmyErr:
    If Err.Number = 429 Then
        Screen.MousePointer = vbDefault
        MsgBox "请先安装EXCEL!", , "导出错误"
        Exit Sub
    End If
    excel_app.DisplayAlerts = False 
    excel_app.Quit '关闭EXCEL
    excel_app.DisplayAlerts = True 
    Set excel_app = Nothing
    MsgBox "导出出错"
    End Sub