4501
1 19.7585
1.666 24.8874
2.332 27.468
2.998 25.9469
Option Explicit
Dim sngData() As Single
Private Sub cmdImport_Click()
Dim intFN As Integer
Dim lngFiles As Long
Dim lngCount As Long
Dim lngStart As Long
Dim lngLines As Long
Me.MousePointer = vbHourglass
Me.Enabled = False
For lngFiles = 0 To File1.ListCount - 1
If File1.Selected(lngFiles) Then
intFN = FreeFile
Open File1.Path & "\" & File1.List(lngFiles) For Input As intFN
Input #intFN, lngLines
lblStatus.Caption = "Reading " & File1.List(lngFiles)
lngStart = UBound(sngData, 2)
If lngStart = 1 Then lngStart = 0
ReDim Preserve sngData(1 To 2, 1 To (lngStart + lngLines))
For lngCount = (lngStart + 1) To (lngStart + lngLines)
Input #intFN, sngData(1, lngCount), sngData(2, lngCount)
Next
Close intFN
End If
Next
Me.MousePointer = vbDefault
Me.Enabled = True
lblStatus.Caption = "Finished Data Import. " & UBound(sngData, 2) & " rows in memory."
End Sub
Notes:
'Note: the following is a much slower way to export the data to Excel
For lngCount = 1 To UBound(sngData, 2)
rngOut.Offset(lngCount - 1, 0).Value = sngData(1, lngCount)
rngOut.Offset(lngCount - 1, 1).Value = sngData(2, lngCount)
rngOut.Offset(lngCount - 1, 2).Formula = "=A" & lngCount & "/B" & lngCount
If (lngCount Mod 100) = 0 Then
lblStatus.Caption = "Now at Excel row " & lngCount & " of " & UBound(sngData, 2) & " rows"
DoEvents
End If
Next
When the export code used this push method, it ran about two minutes. I knew I certainly didn't want my customer waiting that long (or longer) for the export process to finish.
rngChunk.Value = parmxlObj.WorksheetFunction.Transpose(sngData)
statement. During my tests, this statement caused a 13 (type mismatch) trappable error. After a change of variable data type (to Variant) failed to correct the problem, I did a Google search for possible reasons. Turns out that you can only transfer 5461 cell items with a single Transpose function call.
'following statement is in a nested loop, one for each dimension
DataForRange(lngCol, lngLoop) = sngData(lngCol, lngLoop + (lngChunk - 1))
'following statement transfers the chunk of data
rngChunk.Value = parmxlObj.WorksheetFunction.Transpose(DataForRange)
This reduced the run time from two minutes to under five seconds, which was great. But I wondered if there might be some more performance tuning tweaks.
Private Sub cmdExport_Click()
Dim xlObj As Object 'New Excel.Application -- only used with Excel reference
Dim wkbOut As Object 'Excel.Workbook
Dim wksOut As Object 'Excel.Worksheet
Dim rngOut As Object 'Excel.Range
Dim sngStart As Single 'forperformance measurement
'output to Excel workbook
lblStatus.Caption = "Begin Excel Data Export"
Set xlObj = CreateObject("Excel.Application")
Set wkbOut = xlObj.Workbooks.Add
Set wksOut = wkbOut.Worksheets("Sheet1") 'can skip this step
Set rngOut = wksOut.Range("A1") 'by replacing with wkbOut.Worksheets("Sheet1").Range("A1")
Me.MousePointer = vbHourglass
Me.Enabled = False
xlObj.ScreenUpdating = False
xlObj.Calculation = -4135 '=xlCalculationManual
sngStart = Timer
BulkLoad rngOut, sngData
lblStatus.Caption = "Finished Excel Data Export. (" & Timer - sngStart & " seconds)"
xlObj.Calculation = -4105 '=xlCalculationAutomatic
xlObj.ScreenUpdating = True
xlObj.Visible = True
Set rngOut = Nothing
Set wksOut = Nothing
Set wkbOut = Nothing
Set xlObj = Nothing
Me.MousePointer = vbDefault
Me.Enabled = True
End Sub
'================================
'================================
'Note: this version of BulkLoad does not use the Transpose function,
' but it still loads the data in chunks
Private Sub BulkLoad(parmRange As Object, parmData() As Single)
Dim DataForRange() As Single 'may need Variant in future
Dim lngLoop As Long
Dim lngChunk As Long
Dim rngChunk As Object
Dim lngCol As Long
Dim lngChunkSize As Long
lngChunkSize = 5000 \ UBound(parmData, 1)
If UBound(parmData, 2) > lngChunkSize Then
ReDim DataForRange(1 To lngChunkSize, LBound(parmData, 1) To UBound(parmData, 1))
For lngChunk = 1 To (UBound(parmData, 2) - (UBound(parmData, 2) Mod lngChunkSize)) Step lngChunkSize
For lngLoop = 1 To lngChunkSize
For lngCol = LBound(parmData, 1) To UBound(parmData, 1)
DataForRange(lngLoop, lngCol) = sngData(lngCol, lngLoop + (lngChunk - 1))
Next
Next
Set rngChunk = parmRange.Range(parmRange.Offset(lngChunk - 1, 0), parmRange.Offset(lngChunk - 1 + lngChunkSize, 1))
rngChunk.Value = DataForRange
lblStatus.Caption = "Now at Excel row " & lngChunk & " of " & UBound(parmData, 2) & " rows"
Next
'last little chunk
ReDim DataForRange(1 To (UBound(parmData, 2) Mod lngChunkSize), LBound(parmData, 1) To UBound(parmData, 1)) 'UBound(sngData, 2) - 1)
For lngLoop = 1 To (UBound(parmData, 2) Mod lngChunkSize)
For lngCol = LBound(parmData, 1) To UBound(parmData, 1)
DataForRange(lngLoop, lngCol) = sngData(lngCol, lngLoop + (lngChunk - 1))
Next
Next
Set rngChunk = parmRange.Range(parmRange.Cells(lngChunk, 1), parmRange.Cells(lngChunk - 1 + (UBound(parmData, 2) Mod lngChunkSize), 2))
rngChunk.Value = DataForRange
Else
'only little chunk
lngChunk = 1
ReDim DataForRange(1 To UBound(parmData, 2), LBound(parmData, 1) To UBound(parmData, 1))
For lngLoop = 1 To (UBound(parmData, 2) Mod lngChunkSize)
For lngCol = LBound(parmData, 1) To UBound(parmData, 1)
DataForRange(lngLoop, lngCol) = sngData(lngCol, lngLoop + (lngChunk - 1))
Next
Next
Set rngChunk = parmRange.Range(parmRange.Cells(lngChunk, 1), parmRange.Cells(lngChunk - 1 + UBound(parmData, 2), 2))
rngChunk.Value = DataForRange
End If
End Sub
cmdExport_Click Notes:
Private Sub BulkLoadFast(parmRange As Object, parmData() As Single)
Dim DataForRange() As Single
Dim lngLoop As Long
Dim lngChunk As Long
Dim rngChunk As Object
Dim lngCol As Long
Dim lngChunkSize As Long
lngChunkSize = UBound(parmData, 2)
ReDim DataForRange(1 To UBound(parmData, 2), LBound(parmData, 1) To UBound(parmData, 1))
For lngLoop = 1 To lngChunkSize
For lngCol = LBound(parmData, 1) To UBound(parmData, 1)
DataForRange(lngLoop, lngCol) = sngData(lngCol, lngLoop)
Next
Next
Set rngChunk = parmRange.Range(parmRange.Offset(0, 0), parmRange.Offset(lngChunkSize - 1, 1))
rngChunk.Value = DataForRange
End Sub
Note: The cmdExport_Click code is now changed to run this new version.
sngStart = Timer
BulkLoadFast rngOut, sngData
lblStatus.Caption = "Finished Excel Data Export. (" & Timer - sngStart & " seconds)"
Cell-at-a-time 118.72 secs -- OMG! this is terribly sloooow
Transpose() 4.52 secs -- 5000 cell chunks
BulkLoad 4.07 secs -- direct array transfer chunks
BulkLoadFast 2.81 secs -- a single bulk data transfer
Given these figures, the performance times relative BulkLoadFast are:
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (3)
Commented:
Commented:
I like the article :-)
It's well written and reminded me of a blog on another site which is where I initially learned some of the techniques for writing from memory to a range and also got some clarification relating to potential issues when using Transpose. I've decided to post the links here as it may be useful for someone when they are troubleshooting...
John Walkenbach's initial blog is http://www.dailydoseofexcel.com/archives/2006/12/04/writing-to-a-range-using-vba/ and the comments following the blog include:
- Erik Eckhardt provides a link to the same KB article #177991 as you.
- Patrick O'Beirne goes into a little more detail about a limitation of the array method.
- and Fiaz Idris states that the limitation and excel's resulting behaviour have changed in excel 2010.
Thanks
Rob
Author
Commented: