Here, we're writing an array to the sheet in a single 'hit' to the sheet. This is much faster than writing the data into the sheet one cell at a time in lops for the rows and columns.
However, there's some housekeeping to do, as you must specify the size of the target range correctly.
This 'housekeeping' looks like a lot of work and it's probably rather slow: but this is 'last mile' code to write to the sheet, and everything is faster than writing to the worksheet. Or at least, so much faster that it's effectively instantaneous, compared with a read or write to the worksheet, even in VBA, and you should do everything you possibly can in code before you hit the sheet.
A major component of this is error-trapping that I used to see turning up everywhere. I hate repetitive coding: I've coded it all here, and - hopefully - you'll never have to write it again.
As always, watch out for 'helpful' reformatting by your browser (or by Blogger) that inserts line breaks.
Option Explicit
Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray expects a 2-Dimensional structure of the form Variant(Rows, Columns)
' Vector arrays will be written as an array of 1 to n rows in a single column
' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.
' This subroutine saves repetitive coding for a common VBA and Excel task.
' If you think you won't need the code that works around common errors (long
' strings and objects in the array, etc) then feel free to comment it out.
On Error Resume Next
'
' Author: Nigel Heffernan Http://Excellerando.blogspot.com
'
'
' This code is in the public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on your proprietary code
Dim rngOutput As Excel.Range
Dim iRowCount As Long
Dim iColCount As Long
Dim iRow As Long
Dim iCol As Long
Dim arrTemp As Variant
Dim iDimensions As Integer
Dim iRowOffset As Long
Dim iColOffset As Long
Dim iStart As Long
Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
rngTarget.ClearContents
End If
Application.EnableEvents = True
If IsEmpty(InputArray) Then
Exit Sub
End If
If TypeName(InputArray) = "Range" Then
InputArray = InputArray.Value
End If
' Is it actually an array? IsArray is sadly broken so...
If InStr(TypeName(InputArray), "(") < 1 Then
rngTarget.Cells(1, 1).Value2 = InputArray
Exit Sub
End If
iDimensions = ArrayDimensions(InputArray)
If iDimensions < 1 Then
rngTarget.Value = CStr(InputArray)
ElseIf iDimensions = 1 Then
ReDim arrTemp(LBound(InputArray) To UBound(InputArray), 1 To 1)
For iRow = LBound(InputArray) To UBound(InputArray)
arrTemp(iRow, 1) = InputArray(iRow)
Next iRow
ArrayToRange rngTarget, arrTemp
Erase arrTemp
ElseIf iDimensions >= 2 Then
iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)
iStart = LBound(InputArray, 1)
If iRowCount > (65534 - rngTarget.Row) Then
iRowCount = 65534 - rngTarget.Row
InputArray = ArrayTranspose(InputArray)
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
InputArray = ArrayTranspose(InputArray)
End If
iStart = LBound(InputArray, 2)
If iColCount > (rngTarget.Worksheet.Columns.Count - rngTarget.Column) Then
iColCount = rngTarget.Worksheet.Columns.Count - rngTarget.Column - 1
ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
End If
With rngTarget.Worksheet
Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))
Err.Clear
Application.EnableEvents = False
rngOutput.Value2 = InputArray
Application.EnableEvents = True
If Err.Number <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Formula = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
' Have we picked up values that can be read as a formula?
If Left(InputArray(iRow, iCol), 1) = "=" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "+" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
If Left(InputArray(iRow, iCol), 1) = "*" Then
InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Value2 = InputArray
End If 'err<>0
If Err <> 0 Then
For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
If IsError(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = "#ERROR"
ElseIf IsObject(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
ElseIf IsArray(InputArray(iRow, iCol)) Then
InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
ElseIf IsNumeric(InputArray(iRow, iCol)) Then
' no action
Else
InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
If Len(InputArray(iRow, iCol)) > 255 Then
' Block-write operations fail on strings exceeding 255 chars. You
' have to go back and check, and write it out one cell at a time.
InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
End If
End If
Next iCol
Next iRow
Err.Clear
rngOutput.Text = InputArray
End If 'err<>0
If Err <> 0 Then
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
iRowOffset = LBound(InputArray, 1) - 1
iColOffset = LBound(InputArray, 2) - 1
For iRow = 1 To iRowCount
If iRow Mod 100 = 0 Then
Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
End If
For iCol = 1 To iColCount
rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
Next iCol
Next iRow
Application.StatusBar = False
Application.ScreenUpdating = True
End If 'err<>0
Set rngTarget = rngOutput ' resizes the range This is useful, *most* of the time
End With ' rngTarget.Worksheet
End If ' iDimensions
End Sub
Private Function ArrayTranspose(InputArray As Variant) As Variant
Dim arrOutput As Variant
Dim i As Long
Dim j As Long
Dim iMin As Long
Dim iMax As Long
Dim jMin As Long
Dim jMax As Long
iMin = LBound(InputArray, 1)
iMax = UBound(InputArray, 1)
jMin = LBound(InputArray, 2)
jMax = UBound(InputArray, 2)
ReDim arrOutput(jMin To jMax, iMin To iMax)
For i = iMin To iMax
For j = jMin To jMax
arrOutput(j, i) = InputArray(i, j)
Next j
Next i
ArrayTranspose = arrOutput
End Function
Public Function ArrayDimensions(arr As Variant) As Integer
' Return values:
' -1 if arr is not an array
' 0 for an array variant that has not been dimensioned
' 1 to 255 for the array's dimensions.
' Special case: arr isn't a variant, it's a Range object
' Return the dimensions of the range's .Value() property
' VBA will pass the reference to a Range *object* (not the
' object's default property (the .Value variant) into your
' function, even though the parameter was declared as type
' variant. The 'least astonishment' approach to handling
' that is to defer to the infallibility of Microsoft's API
' decisions and return the dimensions of the range's value
' We ignore the possibility of a range with multiple areas
Dim i As Integer
Dim j As Long
If TypeName(arr) = "Range" Then
If arr Is Nothing Then
ArrayDimensions = 0
ElseIf arr.Areas(1).Cells.Count = 1 Then
ArrayDimensions = 1
Else
ArrayDimensions = 2
End If
ElseIf InStr(TypeName(arr), "(") < 1 Then
ArrayDimensions = -1
ElseIf IsEmpty(arr) Then
ArrayDimensions = 0
Else
On Error Resume Next
Err.Clear
For i = 1 To 255
j = 0
j = UBound(arr, i)
If Err.Number <> 0 Then
ArrayDimensions = i - 1
Exit For
End If
Next i
If i > 255 Then ' not a VBA-compatible array
ArrayDimensions = -1
End If
End If
End Function
Please keep the acknowledgements in your source code: as you progress in your career as a developer, you will come to appreciate your own contributions being acknowledged.
