另外查看任务管理器EXCEL  cup 占用        >=50%
vb     cup 占用        16-20%下面是我的代码Dim FileName As String
Dim FolderName As String
Dim Excel_File As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
  Sql = GetSqlString
   Set partsRs = Con.Execute(Sql)
   If partsRs.RecordCount > 0 Then
   Set Excel_File = CreateObject("Excel.Application")
   Set Excel_WorkBook = Excel_File.Workbooks.Add
   Set Excel_Sheet = Excel_WorkBook.Worksheets(1)
  
     partsRs.MoveFirst      Excel_Sheet.Cells(1, 1) = "1"
      Excel_Sheet.Cells(1, 2) = "2"
      Excel_Sheet.Cells(1, 3) = "3"
      Excel_Sheet.Cells(1, 4) = "4"
      Excel_Sheet.Cells(1, 1) = "5"
      Excel_Sheet.Cells(1, 2) = "6"
      Excel_Sheet.Cells(1, 3) = "7"
      Excel_Sheet.Cells(1, 4) = "8"
      Excel_Sheet.Cells(1, 1) = "9"
      Excel_Sheet.Cells(1, 2) = "10"
      Excel_Sheet.Range("A1:J1").HorizontalAlignment = xlCenter      For irow = 1 To partsRs.RecordCount
          Excel_Sheet.Cells(irow + 1, 1).Value = partsRs(0)
          Excel_Sheet.Cells(irow + 1, 2).Value = partsRs(1)
          Excel_Sheet.Cells(irow + 1, 3).Value = partsRs(2) 
          Excel_Sheet.Cells(irow + 1, 4).Value = partsRs(3)
          Excel_Sheet.Cells(irow + 1, 1).Value = partsRs(4)
          Excel_Sheet.Cells(irow + 1, 2).Value = partsRs(5)
          Excel_Sheet.Cells(irow + 1, 3).Value = partsRs(6) 
          Excel_Sheet.Cells(irow + 1, 4).Value = partsRs(7)
          Excel_Sheet.Cells(irow + 1, 1).Value = partsRs(8)
          Excel_Sheet.Cells(irow + 1, 2).Value = partsRs(9)
          Excel_Sheet.Range(Excel_Sheet.Cells(1 + irow, 1), Excel_Sheet.Cells(1 + irow, 10)).HorizontalAlignment = xlCenter
          partsRs.MoveNext
      Next irow
      
      Excel_File.ActiveWorkbook.SaveAs  & "c:\test.xls"  
      Excel_File.ActiveWorkbook.Save
      MsgBox "导出成功!"
      Excel_File.DisplayAlerts = False
      Excel_WorkBook.Close
      Excel_File.Quit
      Set Excel_Sheet = Nothing
      Set Excel_WorkBook = Nothing
      Set Excel_File = Nothing