VB 把查询到的东西输出到EXCEL

Question

麻烦大家 这方面的不是很懂
做了一个小程序 查询的结果显示在datagrid1里面
现在放一个按钮  他就能把我表中显示的输出为一个EXCEL文件   请问大家有没有源代码啊  谢谢   网上搞了好久都不行  7456
麻烦大家了

Answer 1

思路：
1、使用ADO对象把数据查询出来，具体实施方法：http://download.csdn.net/source/1498324
2、将查询出来的数据，写入Excel中，具体实施方法：http://download.csdn.net/source/1604375

Answer 2

如果你读的是Access数据库，最好的办法是：http://download.csdn.net/source/1483928

Answer 3

我做过的一个把txt文件导入excel的例子
Private Sub Command1_Click()
Dim lstLine() As String
Dim Ex As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim lstCol() As String
Dim strTmp As String
Dim intUb As Long
Dim i As Long, intSLine As Long
  Command1.Enabled = False
  lstLine = ReadTextFile(txtFile.Text)
    Set Ex = New Excel.Application
    Ex.Visible = False
    Ex.SheetsInNewWorkbook = 1
    Set xlBook = Ex.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    xlSheet.Columns.NumberFormatLocal = "@"
    intSLine = 0
    lstLine(5) = lstLine(4)
    strTmp = Split(lstLine(5), vbTab, , vbBinaryCompare)(0)
    lblSta(0).Caption = "导入行"
    For i = 5 To UBound(lstLine)
        If i Mod 10 = 0 Then lblSta(1).Caption = i
        DoEvents
        intSLine = intSLine + 1
        If intSLine > 50000 Then
          lblSta(0).Caption = "增加WordSheet"
          DoEvents
          xlBook.Worksheets.Add
          Set xlSheet = xlBook.Worksheets("Sheet" & xlBook.Worksheets.Count)
          xlSheet.Columns.NumberFormatLocal = "@"
          xlSheet.Rows(1).Value = Split(lstLine(5), vbTab, , vbBinaryCompare)
          intSLine = 2
          lblSta(0).Caption = "导入行"
          DoEvents
        End If
        lstCol = Split(lstLine(i), vbTab, , vbBinaryCompare)
        intUb = UBound(lstCol)
        If intUb > 1 Then
          If lstCol(0) <> strTmp Then
            xlSheet.Range(xlSheet.Cells(intSLine, 1), xlSheet.Cells(intSLine, intUb + 1)).Value = lstCol
          Else
            intSLine = intSLine - 1
          End If
        Else
          intSLine = intSLine - 1
        End If
    Next i
    lblSta(0).Caption = "完成"
    lblSta(1).Caption = ""
    Ex.Visible = True
    Set Ex = Nothing
    Command1.Enabled = True
End Sub
  '返回行数组
 Public Function ReadTextFile(FileName As String) As String()
            Dim FileID     As Long
            Dim lstLine() As String
            Dim Id As Long
            On Error Resume Next
              
            FileID = FreeFile()
            ReDim lstLine(0)
            Id = 0
            lblSta(0).Caption = "读取行"
            Open FileName For Input As #FileID
                      Do While Not EOF(FileID)                             '   循环至文件尾。
                        Id = Id + 1
                        ReDim Preserve lstLine(Id)
                        If Id Mod 100 = 0 Then lblSta(1).Caption = Id
                        DoEvents
                        Line Input #FileID, lstLine(Id)
                        lstLine(Id) = Right(lstLine(Id), Len(lstLine(Id)) - 1)
                      Loop
            Close #FileID
            lblSta(0).Caption = "完成"
            lblSta(1).Caption = ""
            ReadTextFile = lstLine
            err.Clear
  End Function

Answer 4

Public Function SaveToExcel(ByVal FileName As String, ByVal DateS As String, ByVal DateE As String)               '導出數據到EXCEL
    Dim xlApp As Object 'Excel.Application
    Dim xlBook As Object 'Excel.Workbook
    Dim xlSheet As Object 'Excel.Worksheet
    Dim I As Long, J As Long, K As Long, tmpStr As String
    
    Set xlApp = CreateObject("Excel.Application")               '創建EXCEL對象
    Set xlBook = xlApp.Workbooks.Add                            '新建EXCEL工作簿文件
    xlApp.Visible = False
    Set xlSheet = xlBook.Worksheets("sheet1")                   '設置活動工作表
    
    I = UBound(MainData)            '從最後的成員開始檢查
    Do
        With MainData(I)
            If MainData(I - 1).xProdNo = .xProdNo And MainData(I - 1).xQty = .xQty Then     '如果與前一成員相同
                .xNoWrite = True        '就標志爲"不寫入"
            End If
        End With
        I = I - 1
    Loop While I > 1                '第一個成員不需要檢查
    
    I = 1
    With MainData(I)
        xlSheet.Cells(I, 1) = "Start Date"
        xlSheet.Cells(I, 2) = "Line"
        xlSheet.Cells(I, 3) = "Shift"
        xlSheet.Cells(I, 4) = "Prod_No"
        xlSheet.Cells(I, 5) = "Req.Qty"
    End With
    
    I = 0       'I代表內存中的記錄
    J = 1       'J代表EXCEL中的行
    Do While I < (UBound(MainData))
        I = I + 1
        If MainData(I).xNoWrite = False Then   '是否允許寫入
            J = J + 1
            With MainData(I)
                Debug.Print "Start Date= " & .xStartDate & " /Line= " & .xLine & " /Shift= " & .xShift & " /Prod_No= " & .xProdNo & " /Req.Qty= " & .xQty
                If CDate(.xStartDate) > CDate(DateS) And _
                   CDate(.xStartDate) < CDate(DateE) Then         '如果在給定的時間範圍內,就寫入
                    Debug.Print "   Write = True"
                    
                    xlSheet.Cells(J, 1) = .xStartDate
                    xlSheet.Cells(J, 2) = .xLine
                    xlSheet.Cells(J, 3) = .xShift
                    K = InStr(.xProdNo, "/")                    '查找"/"
                    If K = 0 Then
                        tmpStr = .xProdNo                       '如果沒有,就直接寫入
                    Else
                        tmpStr = Mid(.xProdNo, 1, K - 1)        '如果有,先寫入前面一部分
                        .xProdNo = Mid(.xProdNo, K + 1, Len(.xProdNo) - K)      '分離出後面部分
                        I = I - 1                               '還原索引值,重新讀一次這個成員
                    End If
                    xlSheet.Cells(J, 4).NumberFormat = "0000"
                    xlSheet.Cells(J, 4) = tmpStr
                    xlSheet.Cells(J, 5) = .xQty
                End If
            End With
        End If
    Loop
    
    xlBook.Close True, FileName                                         '關閉工作簿
    xlApp.Quit                                                      '結束EXCEL對象
    Set xlApp = Nothing                                         '釋放xlApp對象
End Function'MainData的定义.
Private Type XlsData
    xStartDate As String        '日期
    xLine As String             '線別
    xShift As String            '班次
    xProdNo As String           '貨單號
    xQty As Long                '産品數量
    xNoWrite As Boolean         '不寫入輸出表
End TypeDim MainData() As XlsData将结构改成适合你表格的结构,再读入,就可以调用SaveToExcel来直接保存了.

Answer 5

'这是我以前做得一个，供你参考一下
Private Sub Command9_Click() '//导出统计表
    Dim fN As String
    fN = "第三采油厂工区日交接油量统计表"
    writeExcel fNEnd SubPrivate Sub writeExcel(Filename1 As String)
    'On Error GoTo myErr
    Dim FilePath As String, tmp As Byte
    Dim excel_app As Object
    
    '建立 Excel 应用程序
    Set excel_app = CreateObject("Excel.Application")
    
    '显示Excel应用程序
'    excel_app.Visible = True
    
    '添加新工作簿：
    excel_app.workbooks.Add
    
    '检测Excel版本
    If Val(excel_app.Application.Version) >= 12 Then
        FilePath = Filename1 & ".XLSX"
    Else
        FilePath = Filename1 & ".XLS"
    End If
    
    If FileExist(FilePath) Then
        tmp = MsgBox(FilePath & "文件已经存在，是否覆盖？", _
                     vbYesNo, "文件已经存在")
        If tmp = 6 Then
            Kill FilePath
        Else
            GoTo myErr
        End If
    End If
    DoEvents
    
    Screen.MousePointer = vbHourglass
    
    '设置第1个工作表为活动工作表：
    excel_app.Sheets("sheet1").Select
    
    '设置页面为横向
    excel_app.ActiveSheet.PageSetup.Orientation = 2
    
    '//-----------------------------------------------------统计表
        '设置指定列的宽度（单位：字符个数）及对齐方式
        excel_app.ActiveSheet.Columns(1).ColumnWidth = 32
        excel_app.ActiveSheet.Columns(2).ColumnWidth = 13
        excel_app.ActiveSheet.Columns(3).ColumnWidth = 13
        excel_app.ActiveSheet.Columns(4).ColumnWidth = 13
        excel_app.ActiveSheet.Columns(5).ColumnWidth = 13
        excel_app.ActiveSheet.Columns(6).ColumnWidth = 32
        For tmpNum = 1 To 6
            With excel_app.ActiveSheet
                '4右对齐,3居中
                .Columns(tmpNum).HorizontalAlignment = 3
            End With
        Next tmpNum
        
        '添加标题
        excel_app.ActiveSheet.Range(excel_app.ActiveSheet.Cells(1, 1), excel_app.ActiveSheet.Cells(1, 6)).Merge
        excel_app.Cells(1, 1) = Filename1
'        excel_app.Range("A13:M26").Merge
'        excel_app.Range("P12:P19").Merge
'        excel_app.Range("P20:P27").Merge
        
        '设置字体
        With excel_app.ActiveSheet.Range("A3:F12").Font
            .Name = "宋体"
            .Size = 8
        End With
        
        '设置页面和套表框
        With excel_app.ActiveSheet.Range("A3:F12").Borders
            .LineStyle = 1
            .Weight = 2
        End With
        excel_app.ActiveSheet.Range("F13").Select
        
        '添加表头
        For tmpNum = 1 To 6
            excel_app.Cells(3, tmpNum) = Trim(DataGrid3.Columns(tmpNum - 1).Caption)
        Next tmpNum
        
        '添加数据表内容
        iiRow = 4: iiCol = 0: tmpCol = 0
        Do While iiRow - 4 < DataGrid3.VisibleRows'注意如果你想导出的数据超过datagrid的高度，请用Recordset.RecordCount代替datagrid3.visiblerows
            Do While iiCol <= DataGrid3.Columns.Count - 1
                DataGrid3.Row = iiRow - 4
                excel_app.Cells(iiRow, 1 + iiCol + tmpCol) = DataGrid3.Columns(iiCol).Value
                iiCol = iiCol + 1
                DoEvents
            Loop
            iiCol = 0
            tmpCol = 0
            iiRow = iiRow + 1
            DoEvents
        Loop
    
    '工作表另存为：
    If Not excel_app.ActiveWorkBook.Saved Then
        excel_app.ActiveWorkBook.SaveAs FileName:=FilePath
    End If
    ' Close Excel.
    excel_app.Quit
    Set excel_app = Nothing    Screen.MousePointer = vbDefault
    MsgBox "导出了" & Format$(iiRow - 4) & "条记录", , "导出成功"
    
Exit Sub
myErr:
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
'Me.MousePointer = 0
If tmp <> 7 Then MsgBox " 导出数据到 Excel 时出错! ", , "导出错误"End Sub

Answer 6

好多人贴了啊,或者你可以考虑用下VSFLEXGRID这个控件,那样的话直接有导出成EXCEL的函数

Answer 7

Private Sub ExcelDoForVB()
    On Error GoTo errHandler
    Dim I As Integer, j As Integer
    Dim Strfile$
    Dim dialogCancel As Boolean
    Dim myexcel As New Excel.Application
    Dim mybook As New Excel.Workbook
    Dim mysheet As New Excel.Worksheet
    Dim conn As ADODB.Connection
    Set conn = getConnection
    Adodc1.connectionString = conn
    Adodc1.RecordSource = sql
    Adodc1.refresh
    DoEvents
    If Adodc1.Recordset.EOF Then
         Call MessageBox(hWnd, "没有记录！", "提示", MManipulateMsgBox.MB_ICONEXCLAMATION Or MManipulateMsgBox.MB_OK)
    Else
    Set mybook = myexcel.Workbooks.Open(App.Path & "\alarmData.xls")  '打开Excel模板
     myexcel.Visible = False
     myexcel.ActiveSheet.Range("A3:I3").Select
     myexcel.Selection.Cells.CopyFromRecordset Adodc1.Recordset       '复制数据到Excel
         dialogCancel = ShowSave(Me.hWnd, Strfile, "保存Excel", "Excel文件 (*.xls)" & Chr(0) & "*.xls", 1)
            If dialogCancel = True Then
                 Call mybook.SaveAs(Strfile)
                 Call MessageBox(hWnd, "导出成功！", "提示", MManipulateMsgBox.MB_ICONINFORMATION Or MManipulateMsgBox.MB_OK)
            Else
                GoTo killexcelprocess
            End If
    End If
killexcelprocess:
          Set mysheet = Nothing
          myexcel.DisplayAlerts = False
          ' xlBook.Close (False)                '关闭工作簿
          'mybook.Close
          myexcel.Quit                          '关闭Excel
          Set mybook = Nothing
          Set myexcel = Nothing
    Exit Sub

Answer 8

up，使用office组件开发，很容易的！

Answer 9

CopyFromRecordset这个方法方便，一下可以全部导入xlsheet.Range("a1").CopyFromRecordset rsPrivate Sub sub_ExpToExcel()
    Dim xlapp As Excel.Application
    Dim xlbook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset    cn.CursorLocation = adUseClient
    cn.Open ""    rs.Open "select * from mytable", cn, adOpenStatic, adLockOptimistic
    rs.RecordCount
    If rs.RecordCount > 0 Then
        Set xlapp = CreateObject("Excel.Application")
        Set xlbook = xlapp.Workbooks.Add
        Set xlsheet = xlbook.Worksheets(1)        xlsheet.Range("a1").CopyFromRecordset rs        xlsheet.SaveAs strFileName
    End If
    
    rs.Close
    Set rs = Nothing
    
    cn.Close
    Set cn = Nothing
End Sub

Answer 10

李洪根老大的代码，速度快，效率高，稍微修改一下，让它更通用：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
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim xlQuery As Object
'Set xlApp = New Excel.Application    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = ConnectString 'ConnectString就是你的连接字串
        .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

Answer 11

调用：
ExporToExcel ("select × from yourtable")

Answer 12

这样是不简单点，下边这段代码我几个软件都用过，移植性挺好。
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim strFile As StringDim i As Integer
Dim j As IntegerSet xlApp = CreateObject("Excel.Application")   '创建Application对象Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.ActiveSheet   '活动Sheet付值给xlSheet[color=#FF0000]With MSHFlexGrid1 ‘这里就是mshflexgrid控件显示内容[/color]
For i = 0 To .Rows - 1
            .Row = i
For j = 0 To .Cols - 1
            .Col = j
xlSheet.Cells(i + 1, j + 1) = .Text
Next j
Next i
i = 4
   
End With    With CommonDialog1      ’这里是利用commondialog控件选择保存路径和文件名
        .DialogTitle = "Select Excel File To Open"
        .Flags = cdlOFNPathMustExist
        .Filter = "Excel Files (*.xls)|*.xls|所有文件(*.*)|*.* "
        .FileName = "芯片入库统计.xls"
        .InitDir = App.Path
        .ShowOpen
        strFile = .FileName
    End WithxlSheet.SaveAs strFile
Set xlSheet = Nothing
WriteResPassword:="23"
xlBook.Close
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
MsgBox "已形成报表存放指定目录中！", vbOKOnly + vbExclamation, ""

Answer 13

【VB+office】
占位学习，我的最爱！！！！

Answer 14

vb菜鸟，只能边看边学了。正想着在vb中怎么样把查询结果用Excel表导出来了。可以好好研究研究各位NB的人写的代码了。

Answer 15

关键的赋值语句 就一句搞掂     myexcel.ActiveSheet.Range("A3").CopyFromRecordset Adodc1.Recordset