本来从MSFlexGrid或MSHFlexGrid导出数据到Excel中,是一个非常简单的问题,但论坛里还是经常有人问如何导出,有的虽然知道用单元格赋值方式循环导出,但速度太慢,因此写了一个通用的数据导出函数,由于以数组方式一次性赋值,运度速度得到了极大提升,需要的朋友可以参照以下代码,稍作修改,就可以写出用于其它表格控件向Excel导出数据的功能了。
代码如下:
Public Sub ExportToExcel(ByRef objGrid As MSHFlexGrid, ByVal strFileName As String, Optional StartRow As Long = 1, Optional StartColumn As Long = 1) Dim objApp As Object Dim objWorkbook As Object Dim objWorksheet As Object Dim objRange As Object Dim CellsData() As String Dim i As Long, j As Long Dim nRows As Long, nColumns As Long
'构造二维数组 nRows = objGrid.Rows nColumns = objGrid.Cols ReDim CellsData(1 To nRows, 1 To nColumns) For i = 1 To nRows For j = 1 To nColumns CellsData(i, j) = objGrid.TextMatrix(i - 1, j - 1) Next Next
'导出到Excel中 If StartRow < 1 Then StartRow = 1 If StartColumn < 1 Then StartColumn = 1 Set objApp = CreateObject("Excel.Application") objApp.ScreenUpdating = False '禁止屏幕刷新 Set objWorkbook = objApp.Workbooks.Add Set objWorksheet = objWorkbook.Sheets.Add Set objRange = objWorksheet.Range(objWorksheet.Cells(StartRow, StartColumn), objWorksheet.Cells((StartRow - 1) + nRows, (StartColumn - 1) + nColumns)) objRange.Value = CellsData objWorkbook.SaveAs strFileName '保存到指定文件 objWorkbook.Close objApp.Quit '退出Excel Set objRange = Nothing Set objWorksheet = Nothing Set objWorkbook = Nothing Set objApp = Nothing
'销毁二维数组 Erase CellsData End Sub
测试代码如下:
Option Explicit
Private Sub Form_Load() Dim i As Long, j As Long
'填充测试用数据 Me.MSHFlexGrid1.Rows = 2000 Me.MSHFlexGrid1.Cols = 10 For i = 0 To Me.MSHFlexGrid1.Rows - 1 For j = 0 To Me.MSHFlexGrid1.Cols - 1 Me.MSHFlexGrid1.TextMatrix(i, j) = i & "行" & j & "列" Next Next Debug.Print Me.MSHFlexGrid1.TextArray(100) End Sub
Private Sub cmdExport_Click() ExportToExcel Me.MSHFlexGrid1, "d:/temp.xls"
Me.SetFocus MsgBox "导出完毕" End Sub
|