Saturday, 21 July 2012

A generic VBA Array To Range function

Here's a common task: writing an array to a range.

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.

No comments:

Post a comment