I know it is a lot of code, but this function (ArrayToSheet) will put any
array in the sheet:
Option Explicit
'======================================================
'this is just to make it clear what we are dealing with
'======================================================
Private Type SAFEARRAYBOUND
cElements As Long ' +16
lLbound As Long ' +20 <-- this is what we'll change
End Type
Private Type SAFEARRAY
cDims As Integer ' + 0
fFeatures As Integer ' + 2
cbElements As Long ' + 4
cLocks As Long ' + 8
pvData As Long ' +12
Bounds As SAFEARRAYBOUND ' +16
End Type
'======================================================
Private Declare Function VarPtrAry _
Lib "msvbvm60" _
Alias "VarPtr" (Ary() As Any) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (Dest As Any, Src As Any, _
ByVal cBytes As Long)
Function ArrayToSheet(arr As Variant, _
Optional sh As Worksheet, _
Optional ByVal topRow As Long = 1, _
Optional ByVal leftColumn As Long = 1, _
Optional ByVal ClearCells As Byte = 0, _
Optional btCutToSize As Byte = 0, _
Optional bAutofitFields As Boolean = False, _
Optional lLastRow As Long = -1, _
Optional bCorrectLongStrings As Boolean = False) As
Boolean
'puts a 1-dimensional or 2-dimensional array in the sheet
'it will determine the LBound and the number of dimensions
'handles all the errors, except a non-existing sheet
'ClearCells: 0 no clear, 1 clear data, 2 clear all
'btCutToSize: 0 if array too many rows give error message
' 1 if array too many rows cut bottom off
' 2 if array too many rows cut top off
'---------------------------------------------------------
Dim LB1 As Byte
Dim LB2 As Byte
Dim UB1 As Long
Dim UB2 As Long
Dim arrDim As Integer
Dim bOneBase As Boolean
Dim r As Long
Dim c As Long
Dim bLoop As Boolean
If topRow = 1 Then
bAutofitFields = False
End If
'error handling for top row and left column
'------------------------------------------
If topRow > Rows.Count Then
GoTo topRowTooBig
End If
If leftColumn > Columns.Count Then
GoTo leftColTooBig
End If
arrDim = GetArrayDims(arr)
'error handling for array dimensions
'-----------------------------------
If arrDim > 2 Then
GoTo TooManyDimensions
End If
If arrDim = 2 Then
LB1 = LBound(arr, 1)
If lLastRow = -1 Then
UB1 = UBound(arr, 1)
Else
UB1 = lLastRow
End If
Else
LB1 = LBound(arr)
If lLastRow = -1 Then
UB1 = UBound(arr)
Else
UB1 = lLastRow
End If
End If
If arrDim = 2 Then
LB2 = LBound(arr, 2)
UB2 = UBound(arr, 2)
End If
If LB1 = 0 Then
bOneBase = False
Else
bOneBase = True
End If
'error handling for array size
'-----------------------------
If (UB1 + (1 - LB1) + (topRow - 1)) = 0 Then
GoTo NoRows
End If
If (UB1 + (1 - LB1) + (topRow - 1)) > Rows.Count Then
Select Case btCutToSize
Case 0
GoTo TooManyRows
Case 1
'cut bottom off
'--------------
arr = SubArray2(arr, _
LB2, _
UB2, _
(LB1 + UB1 + LB1 + topRow) - Rows.Count, _
UB1, _
bOneBase)
UB1 = UBound(arr)
Case 2
'cut top off
'-----------
arr = SubArray2(arr, _
LB2, _
UB2, _
LB1, _
UB1 - ((UB1 + LB1 + topRow) - Rows.Count), _
bOneBase)
UB1 = UBound(arr)
End Select
End If
If (UB2 + (1 - LB2) + (leftColumn - 1)) > Columns.Count Then
GoTo TooManyColumns
End If
'the IsMissing function doesn't work here
'----------------------------------------
If sh Is Nothing Then
Set sh = ActiveWorkbook.ActiveSheet
End If
'array to sheet
'--------------
With sh
If ClearCells = 1 Then
.Cells.ClearContents
End If
If ClearCells = 2 Then
.Cells.Clear
End If
If arrDim = 2 Then
On Error Resume Next
Range(.Cells(topRow, leftColumn), _
.Cells((UB1 - LB1) + topRow, _
(UB2 - LB2) + leftColumn)) = arr
'this is to cover arrays where an array element is too large
'strangly copying the elements one by one solves it
'-----------------------------------------------------------
If Err.Number = 1004 Then
For r = LB1 To UB1
For c = LB2 To UB2
sh.Cells(topRow + r - LB1, _
leftColumn + c - LB1) = arr(r, c)
Next
Next
bLoop = True
On Error GoTo 0
End If
If bAutofitFields = False Then
Range(.Cells(topRow, leftColumn), _
.Cells((UB1 - LB1) + topRow, _
(UB2 - LB2) + leftColumn)).Columns.AutoFit
Else
Range(.Cells(topRow - 1, leftColumn), _
.Cells((UB1 - LB1) + topRow, _
(UB2 - LB2) + leftColumn)).Columns.AutoFit
End If
Else
Range(.Cells(topRow, leftColumn), _
.Cells(UB1 + (1 - LB1) + (topRow - 1), _
leftColumn)) = _
ArrayTranspose(arr)
Range(.Cells(topRow, leftColumn), _
.Cells(UB1 + (1 - LB1) + (topRow - 1), _
leftColumn)).Columns.AutoFit
End If
'correct for elements of more than 1800 characters
'-------------------------------------------------
If bCorrectLongStrings And bLoop = False Then
On Error Resume Next
If arrDim = 2 Then
For r = LB1 To UB1
For c = LB2 To UB2
If Len(arr(r, c)) > 1800 Then
sh.Cells(topRow + r - LB1, _
leftColumn + c - LB1) = arr(r, c)
End If
Next
Next
Else
For r = LB1 To UB1
If Len(arr(r, c)) > 1800 Then
sh.Cells(topRow + r - LB1, _
leftColumn) = arr(r, c)
End If
Next
End If
On Error GoTo 0
End If
ArrayToSheet = True
End With
'error messages
'--------------
Exit Function
NoRows:
MsgBox "No rows to display", , _
"function array to sheet"
ArrayToSheet = False
Exit Function
TooManyDimensions:
MsgBox "Dimensions: " & arrDim & _
vbCrLf & vbCrLf & _
"This function doesn't work with arrays" & _
vbCrLf & _
"with more than 2 dimensions", , _
"function array to sheet"
ArrayToSheet = False
Exit Function
topRowTooBig:
MsgBox "Top row: " & topRow & _
vbCrLf & vbCrLf & _
"This number of the top row is too big", , _
"function array to sheet"
ArrayToSheet = False
Exit Function
leftColTooBig:
MsgBox "Left column: " & leftColumn & _
vbCrLf & vbCrLf & _
"This number of the left column is too big", , _
"function array to sheet"
ArrayToSheet = False
Exit Function
TooManyRows:
MsgBox "Rows: " & (UB1 + (1 - LB1) + (topRow - 1)) & _
vbCrLf & vbCrLf & _
"This array has too many rows", , _
"function array to sheet"
ArrayToSheet = False
Exit Function
TooManyColumns:
MsgBox "Columns: " & (UB2 + (1 - LB2) + (leftColumn - 1)) & _
vbCrLf & vbCrLf & _
"This array has too many columns", , _
"function array to sheet"
ArrayToSheet = False
End Function
Function GetArrayDims(arr As Variant) As Integer
'---------------------------------------'
'copied from Francesco Balena at: '
'
http://www.devx.com/vb2themax/Tip/18265'
'---------------------------------------'
Dim ptr As Long
Dim VType As Integer
Const VT_BYREF = &H4000&
' get the real VarType of the argument
' this is similar to VarType(), but returns also the VT_BYREF bit
CopyMemory VType, arr, 2
' exit if not an array
If (VType And vbArray) = 0 Then
Exit Function
End If
' get the address of the SAFEARRAY descriptor
' this is stored in the second half of the
' Variant parameter that has received the array
CopyMemory ptr, ByVal VarPtr(arr) + 8, 4
' see whether the routine was passed a Variant
' that contains an array, rather than directly an array
' in the former case ptr already points to the SA structure.
' Thanks to Monte Hansen for this fix
If (VType And VT_BYREF) Then
' ptr is a pointer to a pointer
CopyMemory ptr, ByVal ptr, 4
End If
' get the address of the SAFEARRAY structure
' this is stored in the descriptor
' get the first word of the SAFEARRAY structure
' which holds the number of dimensions
' ...but first check that saAddr is non-zero, otherwise
' this routine bombs when the array is uninitialized
' (Thanks to VB2TheMax aficionado Thomas Eyde for
' suggesting this edit to the original routine.)
If ptr Then
CopyMemory GetArrayDims, ByVal ptr, 2
End If
End Function
Function SubArray2(ByRef InputArray, _
ByVal NewFirstColumn As Long, _
ByVal NewLastColumn As Long, _
Optional ByVal NewFirstRow As Long = 1, _
Optional ByVal NewLastRow As Long = 1, _
Optional ArrayBase As Boolean = True) As Variant
'This function returns as a 0-based or 0-based array any
'sub array of a one- or two-dimensional input array/range,
'as defined by the new first and last rows and columns;
'for a 0-based output array, enter False as the last optional argument.
'Adapted from Alan Beban's array functions to work only with
'1-D or 2-D variant arrays
'---------------------------------------------------------------------
Dim NewArray
Dim i As Long
Dim j As Long
Dim r As Long
Dim s As Long
Dim z As Long
Dim iCols As Integer
Dim iRows As Long
Dim numDim As Integer
Dim base As Integer
On Error Resume Next
'Loop until an error occurs
i = 1
Do
z = UBound(InputArray, i)
i = i + 1
Loop While Err = 0
numDim = i - 2
'Reset the error value for use with other procedures
Err = 0
On Error GoTo 0
base = -ArrayBase
r = base 'Row counter of sub array
s = base 'Column counter of sub array
If numDim = 2 Then
ReDim NewArray(base To NewLastRow - NewFirstRow + base, _
base To NewLastColumn - NewFirstColumn + base) As
Variant
Else
ReDim NewArray(base To NewLastColumn - NewFirstColumn + base) As
Variant
End If
If numDim = 2 Then
'Load sub array
For i = NewFirstRow To NewLastRow
For j = NewFirstColumn To NewLastColumn
NewArray(r, s) = InputArray(i, j)
s = s + 1 'Advance column counter
Next
s = base 'Reset column counter
r = r + 1 'Advance row counter
Next
Else
'Load sub array
For i = NewFirstColumn To NewLastColumn
NewArray(r) = InputArray(i)
r = r + 1
Next
End If
SubArray2 = NewArray
End Function
Function ArrayTranspose(InputArray)
'from Alan Beban's Array functions
'---------------------------------
'This function returns the transpose of
'the input array or range; it is designed
'to avoid the limitation on the number of
'array elements that the worksheet TRANSPOSE
'Function has.
'Declare the variables
Dim outputArrayTranspose()
Dim arr
Dim p As Integer
Dim i As Long
Dim j As Long
'If so, convert an input range to a
'true array
arr = InputArray
'Load the number of dimensions of
'the input array to a variable
p = GetArrayDims(arr)
'Load the output array from a one-
'dimensional input array
If p = 1 Then
ReDim outputArrayTranspose(LBound(arr) To UBound(arr), LBound(arr) To
LBound(arr))
For i = LBound(outputArrayTranspose) To UBound(outputArrayTranspose)
outputArrayTranspose(i, LBound(outputArrayTranspose)) = arr(i)
Next
'Or load the output array from a two-
'dimensional input array or range
Else
If p = 2 Then
ReDim outputArrayTranspose(LBound(arr, 2) To UBound(arr, 2), _
LBound(arr) To UBound(arr))
For i = LBound(outputArrayTranspose) To _
UBound(outputArrayTranspose)
For j = LBound(outputArrayTranspose, 2) To _
UBound(outputArrayTranspose, 2)
outputArrayTranspose(i, j) = arr(j, i)
Next
Next
'Return an error message if the input array
'has more than two dimensions
Else
MsgBox "The ArrayTranspose function does not accept arrays of more
than 2 dimensions."
End If
End If
'Return the transposed array
ArrayTranspose = outputArrayTranspose
End Function
RBS
