Public Function CopyRangeToArray( _
ByVal RangeOfValues As Range, _
Optional ByVal IsSingleDimension As Boolean = True, _
Optional ByVal CaptureText As Boolean = False, _
Optional ByVal TranslateEmptyValuesTo As Variant, _
Optional ByVal TranslateErrorValuesTo As Variant, _
Optional ByVal HandleDates As Boolean _
) As Variant
' Copy the range into a variant array.
'
' Syntax
'
' CopyRangeToArray(RangeOfValues, [IsSingleDimension], [CaptureText], [vErrorValue])
'
' RangeOfValues - The range from which to copy. The range must be contiguous.
'
' IsSingleDimension - Pass True to return a single dimension variant array if
' the range is one row or one column. Otherwise this parameter is ignored.
' Optional. If omitted then True is assumed.
'
' CaptureText - Pass True to capture the Text property of each cell. Optional.
' If omitted then False is assumed.
'
' TranslateEmptyValuesTo - The value to use for any empty cells encountered.
' Optional. If omitted then empty cells are left as is.
'
' TranslateErrorValuesTo - The value to use for any errors encountered.
' Optional. If omitted then errors are left as is. If capturing the Text
' property then errors are as displayed in the cell.
'
' HandleDates - Pass True to handle dates correctly, False to use the default
' handling. The default handling has two potential issues with dates: they
' are converted to strings when copying a single row or column, and dates
' before 3/1/1900 are off by one day earlier. Passing True corrects these two
' problems but uses a process that is slower. Pass False if you are copying
' multiple rows and columns, and all values are not dates or are dates that
' are greater than 2/29/1900. Optional. If omitted then False is assumed.
'
Dim ResultArray As Variant
Dim ArrayIndex As Long
Dim Cell As Range
Dim CellColumn As Long
Dim CellRow As Long
' Copy the range to the variant array
If (RangeOfValues.Rows.Count = 1 Or RangeOfValues.Columns.Count = 1) And IsSingleDimension Then
If CaptureText Then
ReDim ResultArray(1 To WorksheetFunction.Max(RangeOfValues.Rows.Count, RangeOfValues.Columns.Count))
ArrayIndex = 1
For Each Cell In RangeOfValues.Cells
If IsEmpty(Cell) And Not IsMissing(TranslateEmptyValuesTo) Then
ResultArray(ArrayIndex) = TranslateEmptyValuesTo
ElseIf IsError(Cell) And Not IsMissing(TranslateErrorValuesTo) Then
ResultArray(ArrayIndex) = TranslateErrorValuesTo
Else
ResultArray(ArrayIndex) = Cell.Text
End If
ArrayIndex = ArrayIndex + 1
Next Cell
Else
If HandleDates Then
ReDim ResultArray(1 To WorksheetFunction.Max(RangeOfValues.Rows.Count, RangeOfValues.Columns.Count))
For ArrayIndex = LBound(ResultArray) To UBound(ResultArray)
ResultArray(ArrayIndex) = AdjustWorksheetDateValue(RangeOfValues.Cells(ArrayIndex).Value)
Next ArrayIndex
Else
If RangeOfValues.Columns.Count > 1 Then
ResultArray = Application.Transpose(Application.Transpose(RangeOfValues.Value))
Else
ResultArray = Application.Transpose(RangeOfValues.Value)
End If
End If
End If
Else
If CaptureText Then
ReDim ResultArray(1 To RangeOfValues.Rows.Count, 1 To RangeOfValues.Columns.Count)
For CellColumn = 1 To RangeOfValues.Columns.Count
For CellRow = 1 To RangeOfValues.Rows.Count
If IsEmpty(RangeOfValues.Cells(CellRow, CellColumn)) And Not IsMissing(TranslateEmptyValuesTo) Then
ResultArray(CellRow, CellColumn) = TranslateEmptyValuesTo
ElseIf IsError(RangeOfValues.Cells(CellRow, CellColumn)) And Not IsMissing(TranslateErrorValuesTo) Then
ResultArray(CellRow, CellColumn) = TranslateErrorValuesTo
Else
ResultArray(CellRow, CellColumn) = RangeOfValues.Cells(CellRow, CellColumn).Text
End If
Next CellRow
Next CellColumn
Else
ResultArray = RangeOfValues.Value
If HandleDates Then
For CellColumn = LBound(ResultArray, 2) To UBound(ResultArray, 2)
For CellRow = LBound(ResultArray, 1) To UBound(ResultArray, 1)
ResultArray(CellRow, CellColumn) = AdjustWorksheetDateValue(ResultArray(CellRow, CellColumn))
Next CellRow
Next CellColumn
End If
End If
End If
' Translate any error values to the specified replacement value
If Not IsMissing(TranslateErrorValuesTo) And Not CaptureText Then
If IsOneDimensionArray(ResultArray) Then
For CellRow = LBound(ResultArray) To UBound(ResultArray)
If IsEmpty(ResultArray(CellRow)) Then
ResultArray(CellRow) = TranslateEmptyValuesTo
End If
If IsError(ResultArray(CellRow)) Then
ResultArray(CellRow) = TranslateErrorValuesTo
End If
Next CellRow
Else
For CellColumn = LBound(ResultArray, 2) To UBound(ResultArray, 2)
For CellRow = LBound(ResultArray, 1) To UBound(ResultArray, 1)
If IsEmpty(ResultArray(CellRow, CellColumn)) Then
ResultArray(CellRow, CellColumn) = TranslateEmptyValuesTo
End If
If IsError(ResultArray(CellRow, CellColumn)) Then
ResultArray(CellRow, CellColumn) = TranslateErrorValuesTo
End If
Next CellRow
Next CellColumn
End If
End If
CopyRangeToArray = ResultArray
End Function
Public Function AdjustWorksheetDateValue( _
ByVal AdjustValue As Variant _
) As Variant
' Adjust the worksheet date value forward one day if it is before 3/1/1900 and
' return the result.
'
' Syntax
'
' AdjustWorksheetDateValue(AdjustValue)
'
' AdjustValue - Any value.
If IsDate(AdjustValue) Then
If AdjustValue < #3/1/1900# Then
AdjustWorksheetDateValue = AdjustValue + 1
Else
AdjustWorksheetDateValue = AdjustValue
End If
Else
AdjustWorksheetDateValue = AdjustValue
End If
End Function
Public Function IsOneDimensionArray( _
ByVal SourceArray As Variant _
) As Boolean
' Return True if the source array is a one dimension array, False otherwise.
'
' Syntax
'
' IsOneDimensionArray(SourceArray)
'
' SourceArray - Any array.
Dim Result As Long
On Error Resume Next
Result = LBound(SourceArray, 2)
IsOneDimensionArray = Err.Number <> 0
End Function
