求助？？输出到Excel表格？？

直接输入到Excel很慢，方法是先输入到TXt，转换成Excel就很方便了。
1，To Txt
Private Sub CmdTxt_Click()
    HFlexExport mdiMain.dlgCommon, MSHFlexGrid1

End SubFunction HFlexExport(comDialog As CommonDialog, tdbg As MSHFlexGrid, Optional ByVal blCaption As Boolean = True, Optional ByVal blShowAll As Boolean = False, Optional ByVal strSplit As String = ",")
On Error GoTo ProErr
Dim i As Long
Dim j As Integer
Dim strSave As String
Dim FileName As String
Dim txtFile As Scripting.TextStream
Dim LyFile As New Scripting.FileSystemObject
With comDialog
    .CancelError = True
    .InitDir = Left(App.Path, 3)
    .DialogTitle = "蹲"
    .Filter = "Text (*.txt)"
    .FileName = ""
    .Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt + cdlOFNNoReadOnlyReturn + cdlOFNPathMustExist
    On Error Resume Next
    .ShowSave
    If ERR.Number = cdlCancel Then Exit Function
    FileName = .FileName & IIf((.Flags And cdlOFNExtensionDifferent) = cdlOFNExtensionDifferent, "", ".txt")
End With
'
If FileName = "" Then Exit Function
Set txtFile = LyFile.OpenTextFile(FileName, ForAppending, True)
'
WaitOn "糶郎い......"
If blCaption Then
    With tdbg
        For j = 0 To .Cols - 1
            If ((tdbg.ColWidth(j, 0) <> 0 And tdbg.RowHeight(0) <> 0) Or blShowAll = True) Then
                strSave = strSave & .TextMatrix(0, j) & strSplit
            End If
        Next j
    End With
    If strSave <> "" Then txtFile.WriteLine strSave
End If
'.TextMatrix
With tdbg
    .Enabled = False
     For i = 1 To .Rows - 1
         strSave = ""
         For j = 0 To .Cols - 1
             If ((tdbg.ColWidth(j, 0) <> 0 And tdbg.RowHeight(i) <> 0) Or blShowAll = True) Then
                 strSave = strSave & Replace(.TextMatrix(i, j), Chr(13), "") & strSplit
             End If
         Next j
         If strSave <> "" Then txtFile.WriteLine strSave
     Next i
    .Enabled = True
End With
txtFile.Close
Set txtFile = Nothing
Set LyFile = Nothing
WaitOff
Exit Function
ProErr:
WaitOff
tdbg.Enabled = True
Set txtFile = Nothing
Set LyFile = Nothing
End Function2,To Excel创建Excel,把数据存入Excel
Private Sub ComExport_Click()
    Dim xlApp As New Excel.Application
    Dim xlBook As New Excel.Workbook   '定義Excel工作簿對象
    Dim xlSheet As New Excel.Worksheet '定義Excel工作表對象

    Dim line As Integer, M As Integer, n As Integer

    Dim savepath As String  '定義保存路徑

    CommonDialog1.CancelError = True   '設置cancelError為ture

    On Error GoTo errhandler
    CommonDialog1.Flags = cdlOFNHideReadOnly


    CommonDialog1.FileName = "Report"

    CommonDialog1.DefaultExt = ".xls"

    CommonDialog1.Filter = "Excel(*.xls)|*.xls|Text(*.txt)|*.txt"

    CommonDialog1.FilterIndex = 1

    CommonDialog1.Flags = &H2

    CommonDialog1.ShowSave

    If ERR.Number = cdlCancel Then

        Exit Sub

    End If

    savepath = CommonDialog1.FileName

    ''######################以下是匯入到excel

     Set xlApp = CreateObject("Excel.Application")
    ' xlApp.Visible = True         '根据操作人是否需見到Excel此處可設TRUE 或FALSE
    xlApp.Visible = False

    Set xlBook = xlApp.Workbooks.add
    On Error Resume Next
    Set xlSheet = xlBook.Worksheets(1)
    If k = 2 Then  'by 機台編號
        str_eqid = ""
        n = 0
        M = 1                               '得到的str_eqid 用與excel
        For M = 0 To ListSbbh.ListCount - 1
            If ListSbbh.Selected(M) = True Then
                str_eqid = str_eqid & Trim(ListSbbh.List(M))
                If n < ListSbbh.SelCount Then
                    str_eqid = str_eqid
                End If
                n = n + 1
            End If
        Next M
         xlSheet.Cells(1, 4) = "EQ Down Top10 Report"
        xlSheet.Cells(2, 1) = "Date:"
        xlSheet.Cells(2, 2) = Format(DTPickerStart.Value, "yyyy-mm-dd") & "  07:30:00"
        xlSheet.Cells(2, 3) = "TO"
        xlSheet.Cells(2, 4) = Format(DTPickerEnd.Value + 1, "yyyy-mm-dd") & "  07:30:00"
        xlSheet.Cells(3, 1) = "Eqid:"
        xlSheet.Cells(3, 2) = str_eqid

        xlSheet.Cells(4, 1) = "Bug Poenomenon"
        xlSheet.Cells(5, 1) = "Quantity"

        rsgzxx.MoveFirst

        line = 4
        Do While Not rsgzxx.EOF
            xlSheet.Cells(4, line).Value = rsgzxx("poenomenon").Value
            xlSheet.Cells(5, line).Value = rsgzxx("quantity").Value

            line = line + 1
            rsgzxx.MoveNext
        Loop
    End If     xlBook.SaveAs FileName:=savepath, FileFormat:=xlNormal, _
    PassWord:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    CreateBackup:=False
    xlBook.Saved = True   '保存到Excel
    MsgBox "保存成功！", vbOKOnly, "信息"
    '結束EXcel進程
    xlApp.Quit  '不要此句也可以結束進程, 如果加上此句則出現提示是否保存
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing

errhandler:

    Exit Sub

End Sub

在Project-References中选中Microsoft Excel 10.0 Ojbect Library我写的一个例子：
'********************************************************************************
'*   功能  描述：将检索结果得到的临时表内容导出到Excel表格中（
'*   参数  说明：
'*         输入：None
'*         输出：None
'*   返回值说明：成功-1，失败-0
'*   作      者：阿九
'*   更      新：
'*   创建  日期：2004/3/10
'*   更新  日期：
'********************************************************************************
Public Function ExportToExcel() As Long
    Dim uExcel     As Excel.Application
    Dim uExcelBook As Excel.Workbook
    Dim adoCmm     As Command
    Dim adoRec     As Recordset
    Dim strSQL, strTemp   As String
    Dim intList, intI, intJ As Integer 'intRow 行，intList 列
    Dim intRow As Long

    On Error GoTo ErrorHandler

    Set adoCmm = GetCommand
    strSQL = "select count(*) as TotalCount from " & gTempTable '临时表存在的记录数
    adoCmm.CommandText = strSQL
    Set adoRec = adoCmm.Execute
    If Not adoRec.BOF And Not adoRec.EOF Then intRow = adoRec("TotalCount") '取得行数
    intList = 11 '列数固定为11列
    adoRec.Close
    strSQL = "select TestCode,PatCode,OpeUser from " & gTempTable & " order by TestCode"
    adoCmm.CommandText = strSQL
    Set adoRec = adoCmm.Execute
    If intRow > 0 Then
        Set uExcel = New Excel.Application
        uExcel.Visible = True
        uExcel.SheetsInNewWorkbook = 1
        Set uExcelBook = uExcel.Workbooks.Add '打开Excel
        '边框设置
        With uExcel.ActiveSheet.Range("A1:K" & (intRow + 1) & "").Borders
            .LineStyle = 1
            .Weight = xlThin
            .ColorIndex = 1
        End With
        '字体设置(第一行以粗体显示) 高度设为 20
        'With uExcel.ActiveSheet.Range("A1:K1").Font
            '.Size = 14
            '.Bold = True
            '.Italic = True
            '.ColorIndex = 3
        'End With
        uExcel.ActiveSheet.Rows.HorizontalAlignment = xlVAlignCenter     '水平居中
        uExcel.ActiveSheet.Rows.VerticalAlignment = xlVAlignCenter       '垂直居中
        '设置第一行标题
        With uExcel.ActiveSheet
            .Cells(1, 1).Value = "测试编号1"
            .Cells(1, 2).Value = "测试编号2"
            .Cells(1, 3).Value = "操作人员"
            '……
        End With
    End If
    '填充数据行
    intI = 2
    Do While Not adoRec.EOF
        With uExcel.ActiveSheet
            .Cells(intI, 1).Value = adoRec("TestCode")
            .Cells(intI, 2).Value = adoRec("PatCode")
            .Cells(intI, 3).Value = adoRec("OpeUser")
        End With
        intI = intI + 1
        adoRec.MoveNext
    Loop
    adoRec.Close

    'uExcel.ActiveSheet.PageSetup.Orientation = xlPortrait 'xlLandscape
    'uExcel.ActiveSheet.PageSetup.PaperSize = xlPaperA4 '适应于A4纸
    'uExcel.ActiveSheet.PrintOut'打印输出
    'uExcel.DisplayAlerts = False '不保存后退出
    'uExcel.Quit
    'uExcel.DisplayAlerts = True
    'uExcel.Quit
    Set uExcel = Nothing
    Set uExcelBook = Nothing
    ExportToExcel = 1
    Exit Function
ErrorHandler:
    mvarErrorInfo = Err.Description
    ExportToExcel = 0
End Function

如果要直接保存该Excel文件,在程序尾部加入:
        uExcelBook.SaveAs ("C:\Ajiu.xls")
        uExcel.Quit
        uExcel.DisplayAlerts = True
即可其中C:\Ajiu.xls可事先不存在我写的例子是对RecordSet对象集进行操作的

cn.Execute "SELECT * INTO [Excel 8.0;DATABASE=" 路径及文件名"].[" + Str(Date) + "] from 消费 where 日期 between #" & DTPicker1.Value & "# and #" & DTPicker2.Value & "#"
引用EXCEL对象
用法用查询

从MSHFLEXGRID输入出到EXCEL.我觉得最快的方法是这样.
先用下面的函数将网格导出成一个文件,后缀名为".XLS"
然后,用一个EXCEL对象打开该文件.再用EXCEL对象SAVEAS一次成真正的EXCEL格式.
我敢说:这差不多是从网格导出到EXCEL的最快的方法了.Sub TOEXCEL(FileName As String)
    Dim MaxRows As Long
    Dim MaxCols As Long
    Dim StarRow As Long
    Dim ConTents As String
    Dim LoopI As Long
    Dim EndRow As Long
    Dim TmpStr As String
    Dim Tmp As String
    Dim a As Long
    Dim FileID As Long

    With MainGrid
    FileID = FreeFile()
    MaxRows = .Rows - 1: MaxCols = .Cols - 1    DoEvents
    Open FileName For Output As #FileID
         Print #FileID, TmpStr
         For a = 0 To MaxRows
             .Row = a: .Col = 0
             .RowSel = a: .ColSel = MaxCols
              ConTents = .Clip
             Print #FileID, ConTents
             NewVal = a * MaxVal \ MaxRows
       Close #FileID
  End With
End Sub

MSTOP(陈建华(东莞立晨企业资讯服务有限公司)) 方法的灵活性不大好，lilaclone(~~阿九~~) 的方法应该比较可行！！而且速度相当快了

如何调用Public Function ExportToExcel() As Long？？
谢谢

将下文加入到一个模块中,屏幕中调用如下ExporToExcel("select * from table")则实现将其导出到EXCEL中Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer

    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable

    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = Cn
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockReadOnly
        .Source = strOpen
        .Open
    End With
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Function
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With

    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True

    '添加查询语句，导入EXCEL数据
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))

    With xlQuery
        .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

    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh

    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With

    With xlSheet.PageSetup
        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日期："
        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
        .RightFooter = "&""楷体_GB2312,常规""&10第&P页共&N页"
    End With

    xlApp.Application.Visible = True
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = NothingEnd Function
注:须在程序中引用'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000本程序在Windows 98/2000,VB 6 下运行通过

调试易

求助？？输出到Excel表格？？

解决方案 »