怎样把datagrid中的数据导出到Excel中

搜索（VB）
作者：   关键字：导出到Excel

  时间：2004年数据
  最新：15篇  1

用EXCEL2000作为VB的资源文件报表青岛杜运庆许多朋友把EXCEL作为报表的工具，把数据写入EXCEL并不困难，但存在一些问题，如：客户修改了报表的格式，或者把设计好的报表文件删除了，如何解决这些问题呢？搜遍了国内外的站点，亦未发现有什么好的办法。有的朋友给EXCEL文件加密码，这种办法只防止了客户修改报表格式，如果客户移动或删除了这个报表文件，仍然会出问题。现在我们来手绝的：把设计好的空白报表加到资源文件里面，每次报表的时候先把资源文件里面的EXCEL报表写到当前目录下，然后由程序填写数据，或显示或打印！开始吧！先做一些准备工作，在这里假设已准备了以下东东：在当前目录下有一access2000数据库db1.mdb，打开密码是7281322，内有一张表MonRep存放着要报表的数据；设计好的空白EXCEL2000报表rp.xls，打开密码也是7281322。打开VB，新建一个工程，在"工程"→"引用"里面选取Microsoft ActiveX Data Object 2.1 Library和Microsoft Excel 9.0 Object Library；在"外接程序"→"外接程序管理器"里面加载"VB 6 资源编辑器"，在"工程资源管理器"里面点击鼠标右键，选取"添加资源文件"，随便给资源文件起个名字，出现"VB资源编辑器"后，点"添加自定义资源"按钮，选取你设计好的报表rp.xls，点击"保存"按钮，注意：这里使用了默认的类型"CUSTOM"和默认的标识号101，实际应用中你可做修改。按下Ctrl-t，选取Microsoft DataGrid Control 6.0(OLEDB)在默认窗体Form1上画一个 DataGrid，默认名称DataGrid1。在窗体里添加如下代码： Private Sub Form_Load() Dim rst As Recordset Set Cnn1 = New ADODB.Connection CnnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db1.mdb" _ & ";Mode=Read|Write;Persist Security Info=False;Jet OLEDB:Database Password=7281322" Cnn1.Open CnnStr Sql = "SELECT * FROM MonRep" Set rst = New ADODB.Recordset rst.CursorLocation = adUseClient rst.Open Sql, Cnn1, adOpenKeyset, adLockOptimistic, adCmdText Set DataGrid1.DataSource = rst End Sub Private Sub Form_Resize() DataGrid1.Width = 0.95 * Me.Width DataGrid1.Height = 0.75 * Me.Height End Sub 在窗体的"通用"里面添加以下代码：（注意API函数的声明一定要写在一行里） Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Any) As Long Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Const WM_CLOSE = &H10 Const GENERIC_WRITE = &H40000000 Const CREATE_ALWAYS = 2 Const FILE_ATTRIBUTE_NORMAL = &H80 Public Sub CopyExcel() Dim hNewFile As Long, bBytes() As Byte Dim nSize As Long Dim hwnd hwnd = FindWindow("XLMAIN", "Microsoft Excel - rp.xls") If hwnd <> 0 Then SendMessage hwnd, WM_CLOSE, 0, 0'如果客户没有关闭该报表，提示他关闭它 Exit Sub End If If Dir(App.Path & "\rp.xls") = "rp.xls" Then Kill App.Path & "\rp.xls" End If bBytes = LoadResData(101, "CUSTOM") hNewFile = CreateFile(App.Path & "\rp.xls", GENERIC_WRITE, 0, 0, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0) nSize = UBound(bBytes) - LBound(bBytes) + 1 WriteFile hNewFile, bBytes(0), nSize, nSize, ByVal 0& CloseHandle hNewFile End Sub 在窗体上画一按钮，添加以下代码： Private Sub Command1_Click() Me.MousePointer = 11 CopyExcel Dim ex As Object Dim i As Integer Dim j As Integer Dim XlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Set XlApp = CreateObject("Excel.Application") XlApp.Visible = True Set xlBook = XlApp.Workbooks.Open(App.Path & "\rp.xls", , , , 7281322) Set xlSheet = xlBook.Worksheets(1) Dim rst As Recordset Set Cnn1 = New ADODB.Connection CnnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db1.mdb" _ & ";Mode=Read|Write;Persist Security Info=False;Jet OLEDB:Database Password=7281322" Cnn1.Open CnnStr Sql = "SELECT * FROM MonRep" Set rst = New ADODB.Recordset rst.CursorLocation = adUseClient rst.Open Sql, Cnn1, adOpenKeyset, adLockOptimistic, adCmdText rst.MoveFirst For j = 0 To rst.RecordCount - 1 For i = 3 To rst.Fields.Count xlSheet.Cells(i + 2, j + 3) = rst.Fields(i - 1).Value Next i rst.MoveNext Next j For i = 3 To rst.Fields.Count zzz = 0 For j = 0 To rst.RecordCount - 1 zzz = zzz + xlSheet.Cells(i + 2, j + 3) Next j xlSheet.Cells(i + 2, 16) = zzz Next i xlSheet.Cells(3, 15) = Date ' ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True ' xlBook.Close ' XlApp.Quit Me.MousePointer = 0 End Sub 如果你不想显示而是想直接打印报表，可以把XlApp.Visible = True去掉，而启用最后加注释的三行命令。搞定了！按下F5运行后点击按钮，你会看到生成的报表。利用这种方法，你再也不用担心客户破坏你的报表了，爽吗？如果你懒得自己做一遍，到第一VB论坛http://www.vbgood.com去下载我的示例源代码看看吧。该示例代码在以下环境下通过： Win98+VB6SP3+Excl2000+Access2000

strFileName = App.Path & "\Data\OutputExcel" & Format(Now, "yymmddhhMM") & ".xls"
    If Dir(strFileName) <> "" Then
        Kill strFileName
    End If
    strSql = "SELECT * INTO [Excel 8.0;database=" & strFileName & "].SheetName FROM (SELECT * FROM TableName) AS A"
    gConn.Execute strSql

    IRetVal = MsgBox("数据导出到Excel中,保存在： " & strFileName & ",  打开？  ", vbInformation + vbYesNo, "数据导出到Excel中")

    If IRetVal = vbYes Then
        IRetVal = ShellExecute(IWindow, "Open", strFileName, "", "", vbMaximized)
    End If

不用给分的，看见朋友。。
又看见yige答贴了。。
对了楼主，我是先把datagrid循环读出来，再导入到excel下的。
很多的，论坛里，找一下。。

http://dev.csdn.net/develop/article/14/14952.shtm

先把数据导到access中然后用下面的程序，从access转为excel即可
Public Sub AccesstoExcel(AccessPath As String, AccessTablename As String, ExcelPath As String, ExcelSheetName As String)
Dim RsAccesstoExcel As New ADODB.Recordset
Dim CnAccesstoExcel As New ADODB.Connection
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Set xlApp = CreateObject("Excel.Application") '´´½¨EXCEL¶ÔÏó
Set xlBook = xlApp.Workbooks.AddxlApp.Worksheets(ExcelSheetName).Activate
Dim i As Integer
Dim mm As Integer
Dim nn As Integer
Dim jj As IntegerCnAccesstoExcel.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AccessPath & ";Persist Security Info=False"
CnAccesstoExcel.CursorLocation = adUseClient
CnAccesstoExcel.Open
RsAccesstoExcel.Open "select * from " & AccessTablename, CnAccesstoExcel, adOpenDynamic, adLockOptimisticFor i = 1 To RsAccesstoExcel.Fields.Count
    xlApp.Cells(1, i).Value = RsAccesstoExcel.Fields.Item(i - 1).Name
Next
mm = 1
RsAccesstoExcel.MoveFirst
Do While RsAccesstoExcel.EOF <> True
   mm = mm + 1
    For nn = 1 To RsAccesstoExcel.Fields.Count
       If RsAccesstoExcel.Fields.Item(nn - 1).Value <> "" Then
       xlApp.Cells(mm, nn).Value = RsAccesstoExcel.Fields.Item(nn - 1).Value
       Else
       xlApp.Cells(mm, nn).Value = " "
       End If
    Next
   RsAccesstoExcel.MoveNext
Loop
xlApp.DisplayAlerts = False
xlBook.SaveAs (ExcelPath)
xlBook.Close (False)
Set xlApp = Nothing
If CnAccesstoExcel.State <> adStateClosed Then CnAccesstoExcel.Close
End Sub

http://community.csdn.net/Expert/FAQ/FAQ_Index.asp?id=197157
直接把DataGrid里面的数据导出到excel~

Public Sub ToExcel2(mGrid As dataGrid)
    Dim ColCount, i, k As Integer
    Dim xlApp As New Excel.Application, xlBook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet, sRange As String

    ColCount = mGrid.Columns.Count

    xlApp.Visible = True
    Set xlBook = xlApp.Workbooks.Add
    Set xlsheet = xlBook.Worksheets(3)
    xlsheet.Visible = xlSheetHidden
    Set xlsheet = xlBook.Worksheets(2)
    xlsheet.Visible = xlSheetHidden
    Set xlsheet = xlBook.Worksheets(1)
    xlsheet.Name = "MYEXCEL"
    VB.Screen.MousePointer = vbHourglass
    With xlsheet.Range(xlsheet.Cells(1, 1), xlsheet.Cells(1, ColCount))
         .Merge
         .Font.Size = 12
         .Font.Color = vbBlue
         .Value = now
         End With        '//对于excel第一行设置

    For i = 0 To ColCount - 1
       xlsheet.Columns(i + 2).ColumnWidth = mGrid.Columns(i).Width / 120
        If mGrid.Columns(i).Visible = True Then
           ' xlSheet.Columns(i + 1).Font.Color = vbBlue
            xlsheet.Columns.Cells(2, i + 1).Font.Color = vbRed
            xlsheet.Cells(2, i + 1) = mGrid.Columns(i).Caption       '///第二行标每单元标题设置



    End If
    Next
    '//标题

    mGrid.MoveFirst
    i = 0
    While Not mGrid.EOF            '//数据
        xlsheet.Range(xlsheet.Cells(i + 3, 1), xlsheet.Cells(i + 3, ColCount)).Font.Size = 10
        For k = 0 To ColCount - 1
            If Not IsNull(mGrid.Columns(k).Value) Then
                If mGrid.Columns(k).Visible = True Then
                If k = 3 Then
                    xlsheet.Cells(i + 3, k + 1) = CStr("[" & mGrid.Columns(k).Text & "]")
                    Else

                xlsheet.Cells(i + 3, k + 1) = CStr(mGrid.Columns(k).Text)
                End If
             End If
            End If
        Next
        mGrid.MoveNext
        i = i + 1
    Wend
xlBook.SaveCopyAs xlBook.Worksheets(1).Name
VB.Screen.MousePointer = vbDefaultEnd Sub
----------然后调动call ToExcel2(datagrid1)

另一种方法：从表到excel
例如（也要随意改动）：1、建立一个excel模块(*.xlt)
      2、在此模块第一行设置标题
      3、在此模块第二行设置其它数据
　　　4、在此模块第三，四行（上下合并）设置导入字段的标题
      5、在此模块第五，六行分别设置每行空行
-------------------
Private Sub TableToExcel(mouldName As String)     ''如mouldName="kk.xlt"
    Dim ColCount, i, k As Integer
    Dim rs As New ADODB.Recordset
    Dim select1 As String
    Dim xlApp As New Excel.Application, xlBook As Excel.Workbook
    Dim xlsheet As Excel.Worksheet
    Set xlApp = CreateObject("excel.application")
    rs.CursorLocation = adUseClient
    cn.CursorLocation = adUseClient
    If Dir(App.Path + "\Execl\" + mouldName) = "" Then
       MsgBox "不存在对应模板，无法建立!"
Exit Sub
    End If
    Set xlBook = xlApp.Workbooks.Open(App.Path & "\execl\" & mouldName)
select1 = "select * from table1"
If rs.State = 1 Then rs.Close
rs.Open select1, cn, adOpenKeyset, adLockReadOnly
If rs.EOF Or rs.BOF Then MsgBox "无数据记录！", vbCritical: Exit Sub
'//
    ColCount = rs.Fields.Count
    Set xlsheet = xlBook.Worksheets(3)
    xlsheet.Visible = xlSheetHidden
    Set xlsheet = xlBook.Worksheets(2)
    xlsheet.Visible = xlSheetHidden
    Set xlsheet = xlBook.Worksheets(1)
    xlsheet.Name = "导出数据"
    VB.Screen.MousePointer = vbHourglass
    xlsheet.Cells(2, 1) = "还没有想到"
    rs.MoveFirst
    i = 0
    While Not rs.EOF            '//读入数据
       xlApp.Rows(i + 6).Select
       xlApp.Selection.Insert Shift:=xlUp
        For k = 0 To ColCount - 1
        xlsheet.Cells(i + 5, k + 1) = CStr(IIf(IsNull(rs.Fields(k)) = True, "-", rs.Fields(k)))
        Next
        rs.MoveNext
        i = i + 1
    Wend

  xlApp.Visible = True
xlBook.SaveCopyAs xlBook.Worksheets(1).Name
VB.Screen.MousePointer = vbDefault
End Sub

用记录集的方式导。
可以将excel看成一个数据库，用ADO和excel连接，在用 create table语句建表，字段自己写。
在用 accrst.addnew
   rst(ii).value=accrst(jj).value
     rst.move
     accrst.update
的方式导出即可。
例：
Private Sub Command1_Click()
Dim AppExcel As Object
Dim ECnn As New ADODB.Connection
Dim ExcelRst As New ADODB.Recordset
Dim AppName As String
Dim i As Integer, j As Integer, k As Integer
Dim F As String
Dim Ctable As String
Dim AA As Integer

Sub_start:

  AppName = Trim(Text1.Text)
  If Right$(AppName, 4) <> ".xls" Then
     MsgBox "文件选择有问题,请重试!", vbOKOnly + vbExclamation, "警告"
      Else
      If Rst.State = adStateClosed Then
      MsgBox "当前没有记录，无法导出！", vbOKOnly + vbExclamation, "警告"
        Else
   ECnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AppName & ";Extended Properties=excel 8.0;Persist Security Info=False"
   ECnn.CursorLocation = adUseClient
   ECnn.Open

   On Error GoTo Excel_error
   ECnn.Execute "create table [Sheet1] (" & CreateTable & ")"

   ExcelRst.Open "select * from [Sheet1]", ECnn, adOpenForwardOnly, adLockOptimistic

     If Rst.RecordCount = 0 Then
      MsgBox "记录集有问题，不能导出!", vbOKOnly + vbQuestion, "警告"
      Else
      Rst.MoveFirst
      ProgressBar1.Min = 0
      ProgressBar1.Max = Rst.RecordCount
      ProgressBar1.Value = 0
   Do While Not Rst.EOF
    ExcelRst.AddNew
      For i = 0 To Rst.Fields.Count - 1
       ExcelRst(i).Value = Rst.Fields(i).Value
      Next i
     ExcelRst.Update
    Rst.MoveNext
     ProgressBar1.Value = ProgressBar1.Value + 1
      Loop
     MsgBox "导出成功", vbOKOnly + vbExclamation, "提示"
     Unload Me
    End If
   End If
   Exit SubExcel_error:
   F = MsgBox("是否覆盖", vbYesNo + vbExclamation, "警告")
    If F = vbYes Then
      If ECnn.State = adStateOpen Then
       ECnn.Close
       Kill AppName
      GoTo Sub_start
      Else
      Kill AppName
      GoTo Sub_start
      End If
      Else
    MsgBox "导出失败", vbOKOnly + vbExclamation, "提示"
     End If
   End If
  End Sub

调试易

怎样把datagrid中的数据导出到Excel中

解决方案 »