如何把MSHFlexGrid里的数据导出至Excel？
用Adodc1做了查询语句，结果显示在一个MSHFlexGrid里面。现在要求做一个按钮（Command1），点击它就把MSHFlexGrid里显示的数据导出至Excel表中。就是一点这个按钮，就会自动打开Excel，然后数据就已经进去了，方便编辑和打印。
要求：代码详细，直接复制到Command1下就能用。这块我不懂，所以不要搞什么子程序调用之类的，要有子程序也给直接调用好。
直接复制代码成功后，再追加100分。把这个弄完工程就结了，再不用受罪了，哈哈！
以下是精简后的代码，不清楚你工作中的一些细节，所以如有问题与我讨论
Private Sub Command1_Click()
MSFlexGrid1.Redraw = False '关闭表格重画，加快运行速度
Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
Set xlBook = & "\对账模板.xls") '打开已经存在的EXCEL工件簿文件
xlApp.Visible = True '设置EXCEL对象可见（或不可见）
Set xlsheet = xlBook.Worksheets("Sheet1") '设置活动工作表
For R = 0 To MSFlexGrid1.Rows - 1 '行循环
For C = 0 To MSFlexGrid1.Cols - 1 '列循环
MSFlexGrid1.Row = R
MSFlexGrid1.Col = C
xlBook.Worksheets("Sheet1").Cells(R + 1, C + 1) = MSFlexGrid1.Text '保存到EXCEL Next C
Next R
MSFlexGrid1.Redraw = True
'xlsheet.PrintOut '打印工作表
xlApp.DisplayAlerts = False '不进行安全提示
'xlBook.Close (False) '关闭工作簿
Set xlsheet = Nothing
Set xlBook = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
下面的代码就也能导出到EXCEL
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim i As Long, J As Long
On Error GoTo ErrorHandle
Set xlApp = CreateObject( "Excel.Application ")
Set xlBook =
Set xlSheet = xlBook.Worksheets(1)
For i = 0 To MHFGrid.Rows - 1
For J = 0 To MHFGrid.Cols - 1
xlSheet.Cells(i + 1, J + 1).Value = MHFGrid.TextMatrix(i, J)
Next J
Next i
= True
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
ErrorHandle:
MsgBox "错误：" & Err.Number & vbCrLf & Err.Description, vbOKOnly, "运行错误"
如何将表中的数据导出到电子表格中
作者：施进兵
有很多方法都可将数据库中某个表的数据导出到电子表格中，例如通过创建Access.Application，可以利用Access本身的导出功能实现将表中的数据导出到电子表格中。但是这种方法会占用较多的系统资源，并且缺乏通用性。如果一个数据库没有导出的功能怎么办？下面的这段程序代码利用记录集实现导出的功能，这种做法的好处是显而易见的：你可以控制要导出的数据，而不用将整个表的内容都导出到电子表格中。为简单起见下面的程序代码仍将整个表的数据导出到电子表格中。如果你有兴趣的话，对下面的代码稍加改动就可做成更为通用的一个类或是一个控件。
首先在窗体上添加一个标签控件和一个命令按钮，然后在工程中添加对DAO引用。利用下面的程序代码就可将表中的数据导出到电子表格中。
Option Explicit
Private Sub Command1_Click()
Dim tempDB As Database
Dim i As Integer ' 循环计数器
Dim j As Integer
Dim rCount As Long ' 记录的个数
Dim xl As Object ' OLE自动化对象
Dim Sn As Recordset
Screen.MousePointer = 11
怎么创建excel表格Label1.Caption = "打开数据库... "
Label1.Refresh
Set tempDB = Workspaces(0).OpenDatabase( "Nwind.mdb ")
Label1.Caption = "创建Excel对象... "
Label1.Refresh
Set xl = CreateObject( "Excel.Sheet.8 ")
Label1.Caption = "创建快照型记录集... "
Label1.Refresh
Set Sn = tempDB.OpenRecordset( "Customers ", dbOpenSnapshot)
If Sn.RecordCount > 0 Then
Label1.Caption = "将字段名添加到电子表格中"
Label1.Refresh
For i = 0 To - 1
xl.Worksheets(1).cells(1, i + 1).Value = Sn(i).Name
Next
Sn.MoveLast
Sn.MoveFirst
rCount = Sn.RecordCount
' 在记录中循环
i = 0
Do While Not Sn.EOF
Label1.Caption = "Record: " & Str(i + 1) & " of " & _
Str(rCount)
Label1.Refresh
For j = 0 To - 1
' 加每个字段的值加到工作表中
If Sn(j).Type < 11 Then
xl.Worksheets(1).cells(i + 2, j + 1).Value = Sn(j)
Else
' 处理Memo和LongBinary 类型的字段
xl.Worksheets(1).cells(i + 2, j + 1).Value = "Memo or Binary Data "
End If
Next j
Sn.MoveNext
i = i + 1
Loop
' 保存工作表
Label1.Caption = "保存文件... "
Label1.Refresh
xl.SaveAs "c:\Customers.XLS "
'从内存中删除Excel对象
Label1.Caption = "退出Excel "
Label1.Refresh
Else
' 没有记录
End If
' 清除
Label1.Caption = "清除对象"
Label1.Refresh
Set xl = Nothing
Set Sn = Nothing
Set tempDB = Nothing
Screen.MousePointer = 0 ' 恢复鼠标指针
Label1.Caption = "Ready "
Label1.Refresh
End Sub
Private Sub Form_Load()
Label1.AutoSize = True
Label1.Caption = "Ready "
Label1.Refresh
End Sub
给你个我用的方法，很好用
'Option Explicit
''*********************************************************
''* 名称：ExportToExcel
''* 功能：导出数据到EXCEL
''* 用法：ExporToExcel 记录集，标题
''*********************************************************
'Public Function ExportToExcel(Rs_Data As ADODB.Recordset, CenterHeader As String) As Boolean ' Dim Irowcount As Integer
' Dim Icolcount As Integer
' Dim SA As String
' Dim xlApp As New Excel.Application
' Dim xlBook As Excel.Workbook
' Dim xlSheet As Excel.Worksheet
' Dim xlQuery As Excel.QueryTable
'On Error GoTo err
' With Rs_Data
' If .state = adStateOpen Then
' .Close
' End If
' .ActiveConnection = DBConn
' .CursorLocation = adUseClient
' .CursorType = adOpenStatic
' .LockType = adLockReadOnly
' '.Source = strOpen
' .Open
' End With
' With Rs_Data
' '记录总数
' 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 = False
' '添加查询语句，导入EXCEL数据
' Set xlQuery = , 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
' If CenterHeader = "开停历史纪录" Then
' SA = "A1:H" + CStr(Irowcount + 1)
' ElseIf CenterHeader = "锁闭阀运行状态" Then
' SA = "A1:F" + CStr(Irowcount + 1)
' ElseIf CenterHeader = "锁闭阀分配表" Then
' SA = "A1:F" + CStr(Irowcount + 1)
' ElseIf CenterHeader = "用户信息汇总" Then
' SA = "A1:I" + CStr(Irowcount + 1)
' ElseIf CenterHeader = "锁闭阀开停设置" Then
' SA = "A1:H" + CStr(Irowcount + 1)
' ElseIf CenterHeader = "房间信息" Then
' SA = "A1:J" + CStr(Irowcount + 1)
' End If
' With xlSheet
' '.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "宋体"
' '.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Size = 10
' '标题字体加粗
' '.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous ' '设表格边框样式
'字体
' .Range(SA).Font.Name = "宋体"
' .Range(SA).Font.Size = 10
' '设标题为黑体字
' .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
'列宽度
' If CenterHeader = "开停历史纪录" Then
' .Columns("A:A").ColumnWidth = 8.63
' .Columns("B:B").ColumnWidth = 11.38
' .Columns("C:C").ColumnWidth = 12.63
' .Columns("D:D").ColumnWidth = 6.75
' .Columns("E:E").ColumnWidth = 13.31
' .Columns("F:F").ColumnWidth = 7
' .Columns("G:G").ColumnWidth = 7
' .Columns("H:H").ColumnWidth = 7.63
' End If
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论