将控件MSHFlexGrid中的数据导出到EXECL，2000条数据导出过程要7分钟

Question

此段代码是将控件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

Answer 1

比如以下代码，导出速度非常快，如果不显示excel，速度会更快。Option ExplicitPrivate 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 SubPrivate 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