将控件MSHFlexGrid中的数据导出到EXECL，2000条数据导出过程要7分钟
此段代码是将控件MSHFlexGrid里的数据导出到EXECL，，，，但是当数据有2000条以上的时候，导出要花7分钟左右，请高手帮忙查一下问题出在哪？谢谢
On Error Resume Next
If MSHFlexGrid1.TextMatrix(1, 2) = "" Then
MsgBox "没有数据导出", vbInformation, "提示"
Exit Sub
End If
Dim excelApp As Excel.Application
Set excelApp = New Excel.Application
Set excelApp = CreateObject("Excel.Application")
Dim exbook As Excel.Workbook
Dim exsheet As Excel.Worksheet
Set exbook = excelApp.Workbooks.Add
excelApp.SheetsInNewWorkbook = 1
excelApp.Visible = False '是否显示导出过程(true是)
excelApp.UserControl = True
Me.MousePointer = vbHourglass '控制鼠标为读取数据
'''''''''''''''''''''''''''''''''''''''''''表头设置'''''''''''''''''''''''''''''''''''''
With excelApp.ActiveSheet '表头合并
.Range("a1:p4").Merge '合并
.Range("a1:p4") = "商品基本信息资料"
.Rows.HorizontalAlignment = xlVAlignCenter '
End With
With excelApp.ActiveSheet
.Range("A1:p4").Borders.LineStyle = xlContinuous '表头边框线
End With
''''''''''''''''''''''''''''''''报表日期--
' With excelApp.ActiveSheet
' .Range("i5:i5") = "报表日期:" & Format$(Date, "yyyy-mm-dd")
' End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
With excelApp.ActiveSheet
.Range("a5:a5") = "序号"
.Range("b5:b5") = "商品编号 "
.Range("c5:c5") = "商品款号"
.Range("d5:d5") = "商品名称"
.Range("e5:e5") = "单位"
.Range("f5:f5") = "商品颜色"
.Range("g5:g5") = "商品尺码"
.Range("h5:h5") = "商品类别"
.Range("i5:i5") = "商品种类"
.Range("j5:j5") = "品牌"
.Range("k5:k5") = "吊牌价"
.Range("l5:l5") = "销售价"
.Range("m5:m5") = "建档日期"
.Range("n5:n5") = "上市波段"
.Range("o5:o5") = "商品成份"
.Range("p5:p5") = "备注"
End With
With excelApp.ActiveSheet
.Cells(1).ColumnWidth = 9
.Cells(2).ColumnWidth = 12 '第一列
.Cells(3).ColumnWidth = 10 '第二列
.Cells(4).ColumnWidth = 12 '第三列
.Cells(5).ColumnWidth = 12 '第四列
.Cells(6).ColumnWidth = 8 '第五列
.Cells(7).ColumnWidth = 32 '第六列
.Cells(8).ColumnWidth = 8 '第七列
.Cells(9).ColumnWidth = 8 '第八列
.Cells(10).ColumnWidth = 12 '第九列
.Cells(11).ColumnWidth = 10 '第九列
.Cells(12).ColumnWidth = 10 '第九列
.Cells(13).ColumnWidth = 10 '第九列
.Cells(14).ColumnWidth = 10 '第九列
.Cells(15).ColumnWidth = 10 '第九列
End With
With excelApp.ActiveSheet
.Range("A5:p5").Borders.LineStyle = xlContinuous '表头边框线
End With
'''''''''''''''''''''''''''导出MSFLEXGRID内容'''''''''''''''''''''''''''''''''
With excelApp.ActiveSheet
For i = 1 To MSHFlexGrid1.Rows
For j = 1 To MSHFlexGrid1.Cols
.Cells(i + 5, j).Value = "" & Format$(MSHFlexGrid1.TextMatrix(i, j))
.Cells(i + 5, 3).Value = "'" & MSHFlexGrid1.TextMatrix(i, 3)
Next j
.Range("a" & 6 & ":" & "p" & MSHFlexGrid1.Rows + 4).Borders.LineStyle = xlContinuous '设置横线(边框)
Next i
End With
With excelApp
'--------------------------------另存为-----------------------------
abc = "商品基本资料" & Format$(Date, "yyyymmdd")
aa = .Dialogs(xlDialogSaveAs).Show(abc) '
.Workbooks(1).Saved = True '不提示保存对话框
'-------------------------------
End With
Me.MousePointer = 0 '释放鼠标为读取数据
exbook.Close (True) '关闭EXBOOK
excelApp.Quit '退出
Set exsheet = Nothing '释放EXCEL
Set exbook = Nothing '释放EXCEL
Set excelApp = Nothing '释放EXCEL
MsgBox "导出成功！", vbOKOnly + vbInformation, "消息提示"
End Sub
[解决办法]
比如以下代码，导出速度非常快，如果不显示excel，速度会更快。
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()
Dim i As Long, j As Long
Dim CellsData() As String
Dim objApp As Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim objRange As Excel.Range
'构造二维数组
ReDim CellsData(1 To Me.MSHFlexGrid1.Rows, 1 To Me.MSHFlexGrid1.Cols)
For i = 1 To Me.MSHFlexGrid1.Rows
For j = 1 To Me.MSHFlexGrid1.Cols
CellsData(i, j) = Me.MSHFlexGrid1.TextMatrix(i - 1, j - 1)
Next
Next
'导出到Excel中
Set objApp = New Excel.Application
objApp.ScreenUpdating = False '禁止屏幕刷新
Set objWorkbook = objApp.Workbooks.Add
Set objWorksheet = objWorkbook.Sheets.Add
Set objRange = objWorksheet.Range(objWorksheet.Cells(1, 1), objWorksheet.Cells(Me.MSHFlexGrid1.Rows, Me.MSHFlexGrid1.Cols))
objRange.Value = CellsData
objApp.Visible = True
objApp.ScreenUpdating = True
'销毁二维数组
Erase CellsData
Me.SetFocus
MsgBox "导出完毕"
End Sub
