很菜的问题不要小我

Question

我做程序时常常需要打印数据，我把数据表中的数据通过程序导入EXCEL时，通常很慢，请问各位高手，我怎么样才能提高到入数据的速度，用程序来实现！

Answer 1

将excel文件当做数据库来打开及操作，速度比用excel对象打开操作快许多；一下是一个代码片段，稍微修改就可供你用的：    Dim ConStr As String
    
    ConStr = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & vFileName & ";Extended Properties='Excel 8.0;HDR=Yes'"
    cnnJet.Open ConStr
     
    Set rsSchema = cnnJet.OpenSchema(adSchemaTables)
     
    '¶ÔexcelÖеÄËùÓÐsheet
    Do While Not rsSchema.EOF
        rs.Open "select * from [" & rsSchema.Fields("Table_Name") & "]", cnnJet, adOpenKeyset, adLockOptimistic
        
        'Èç¹ûsheetÖдæÔڼǼ
        If rs.RecordCount > 0 And rs.Fields.Count > 1 Then
                While Not rs.EOF

Answer 2

conn.ConnectionString:="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\rsc\try1.xls;Extended Properties=excel 8.0;Persist Security Info=False"
conn.open
conn.execute("select * into 表名 from tablename in 'd:\rscb\zw.mdb' 'jet 3.x;'")

Answer 3

很谢谢你qqyy_sj，但是你做的比我的还要慢啊！很高兴认识你。希望和你交个朋友
  谢谢小刘，你的程序过到我机器这边有写乱码。

Answer 4

Public Cn As New ADODB.Connection                  '连接方式
Public Rs As New ADODB.Recordset                   '记录集
Dim CreatSql As String                              'sql语句
Dim Excel As Excel.Application ' This is the excel program
Dim ExcelWBk As Excel.Workbook ' This is the work book
Dim ExcelWS As Excel.Worksheet ' This is the sheet
Dim ExcelQuery As Excel.QueryTable
'------------------------------------ 
With Rs
        If .State = adStateOpen Then .Close
        .ActiveConnection = Cn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = CreatSql
        .Open
    End With
    '对记录进行快速添加到excel 中去
    If Rs.RecordCount = 0 Then
        MsgBox "没有记录", 48, "平衡力量管理信息系统"
        Exit Sub
    End If
    '启动excel程序
    Call StartExcel
    Set ExcelWBk = Nothing
    Set ExcelWS = Nothing
    Set ExcelWBk = Excel.Workbooks.Add    'Add this Workbook to Excel.
    Set ExcelWS = ExcelWBk.Worksheets("sheet1") ' Add this sheet to this Workbook
    Excel.Visible = False
    '添加数据到excel
       '---------------添加数据
    Set ExcelQuery = ExcelWS.QueryTables.Add(Rs, ExcelWS.Range("a1"))
    With ExcelQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
    ExcelQuery.Refresh
    Excel.Visible = True
    Set Excel = Nothing
    Set ExcelWBk = Nothing
    Set ExcelWS = NothingPrivate Sub StartExcel()
On Error GoTo err: 
    Set Excel = GetObject(, "Excel.Application") ' Create Excel Object.
    'Excel.Visible = True ' Show Excel
    Exit Sub
err:
    Set Excel = CreateObject("Excel.Application") 'Create Excel Object.  
End Sub

Answer 5

Dim i As Integer
    Dim j As Integer
 If MsgBox("确认打印表格上的数据么?", vbYesNo) = vbYes Then
    Call gsubOpen_Excel("CheckHouseFacs.xls")
     On Error Resume Next
      For i = 1 To Me.MSHFlexGrid1.Rows - 1
        Me.MSHFlexGrid1.Row = i
        For j = 1 To Me.MSHFlexGrid1.Cols
            Me.MSHFlexGrid1.Col = j - 1
            xSheet.Cells(i + 1, j) = Me.MSHFlexGrid1.text
                  
          Next j
    Next i
'    Call subSetCheckReportData(PrintDataSheet)
    Call gsubPrint(sPreview, 1)
 Else
    Exit Sub
 End If
Public Sub gsubOpen_Excel(FileName As String)  'NewFielName 文件名包含完整的路径
    Dim strSource, strDestination As String
     'strSource 就是一个模版文件
     strSource = App.Path & "\" & FileName
'      strDestination = "c:" & "\aa.xls"
     '将模版文件拷贝成新生成的文件
     '打开Excel进行编辑
'     On Error Resume Next
'     FileCopy strSource, strDestination
     Set xExcel = New Excel.Application
     Set xExcel = CreateObject("Excel.Application")
     xExcel.Visible = False
    
     Set xBook = xExcel.Workbooks.Open(strSource)
     Set xSheet = xExcel.Worksheets(1)
     xSheet.Activate
End Sub
Public Sub gsubPrint(PrintMod As PrintStyle, intCopies As Integer)
    Select Case PrintMod
        Case 1
              xBook.Save
              xSheet.PrintOut , , intCopies
       Case 2
              xBook.Save
              xExcel.Visible = True
              xSheet.PrintPreview
    End Select
    xExcel.Quit
    Set xExcel = Nothing
End Sub
这是我的程序的一部分，请大家看看，什么地方可以优化一下，让它运行起来更快。

Answer 6

Dim i As Integer
    Dim j As Integer
 If MsgBox("确认打印表格上的数据么?", vbYesNo) = vbYes Then
    Call gsubOpen_Excel("CheckHouseFacs.xls")
     On Error Resume Next
      For i = 1 To Me.MSHFlexGrid1.Rows - 1
        Me.MSHFlexGrid1.Row = i
        For j = 1 To Me.MSHFlexGrid1.Cols
            Me.MSHFlexGrid1.Col = j - 1
            xSheet.Cells(i + 1, j) = Me.MSHFlexGrid1.text
                  
          Next j
    Next i
'    Call subSetCheckReportData(PrintDataSheet)
    Call gsubPrint(sPreview, 1)
 Else
    Exit Sub
 End If
Public Sub gsubOpen_Excel(FileName As String)  'NewFielName 文件名包含完整的路径
    Dim strSource, strDestination As String
     'strSource 就是一个模版文件
     strSource = App.Path & "\" & FileName
'      strDestination = "c:" & "\aa.xls"
     '将模版文件拷贝成新生成的文件
     '打开Excel进行编辑
'     On Error Resume Next
'     FileCopy strSource, strDestination
     Set xExcel = New Excel.Application
     Set xExcel = CreateObject("Excel.Application")
     xExcel.Visible = False
    
     Set xBook = xExcel.Workbooks.Open(strSource)
     Set xSheet = xExcel.Worksheets(1)
     xSheet.Activate
End Sub
Public Sub gsubPrint(PrintMod As PrintStyle, intCopies As Integer)
    Select Case PrintMod
        Case 1
              xBook.Save
              xSheet.PrintOut , , intCopies
       Case 2
              xBook.Save
              xExcel.Visible = True
              xSheet.PrintPreview
    End Select
    xExcel.Quit
    Set xExcel = Nothing
End Sub
这是我的程序的一部分，请大家看看，什么地方可以优化一下，让它运行起来更快。

Answer 7

Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Set xlApp = CreateObject("Excel.Application")
       
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    
        xlSheet.cells(1, 1).Value = "a"
        xlSheet.cells(1, 2).Value = "b"
        xlSheet.cells(1, 3).Value = "c"
        xlSheet.cells(1, 4).Value = e"
        xlSheet.cells(1, 5).Value = f"
        xlSheet.cells(1, 6).Value = "g"    'rs是从数据库中选出的欲导入excel的记录集
    xlSheet.Range("A2").CopyFromRecordset rs        
    xlBook.SaveAs Filename:="文件名"
    xlApp.Quit