The following function will extract a sub array from a 3-D array:

Function SubArray3D(inputArray, Optional ByVal NewFirstRow, _
Optional ByVal NewLastRow, _
Optional ByVal NewFirstColumn, _
Optional ByVal NewLastColumn, _
Optional ByVal NewFirst3rd, _
Optional ByVal NewLast3rd)
'This function returns as an array any sub array of
'a three-dimensional input array, as defined by
'the new first and last rows, columns and 3rd dimension.

Dim NewArray, i As Long, j As Long, k As Long
Dim p As Long, q As Long, r As Long, Msg, numDim
Dim nfr, nlr, nfc, nlc, nf3, nl3

nfr = NewFirstRow
nlr = NewLastRow
nfc = NewFirstColumn
nlc = NewLastColumn
nf3 = NewFirst3rd
nl3 = NewLast3rd

If Not TypeName(inputArray) Like "*()" Then
Msg = "#ERROR! This function accepts only arrays."
MsgBox Msg, 16
Exit Function
End If

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

If numDim < 3 Then
Msg = "#ERROR! This function accepts only 3-D arrays."
MsgBox Msg, 16
Exit Function
End If

lb1 = LBound(inputArray)
ub1 = UBound(inputArray)
lb2 = LBound(inputArray, 2)
ub2 = UBound(inputArray, 2)
lb3 = LBound(inputArray, 3)
ub3 = UBound(inputArray, 3)
If IsMissing(NewFirstRow) Then nfr = lb1
If IsMissing(NewLastRow) Then nlr = ub1
If IsMissing(NewFirstColumn) Then nfc = lb2
If IsMissing(NewLastColumn) Then nlc = ub2
If IsMissing(NewFirst3rd) Then nf3 = lb3
If IsMissing(NewLast3rd) Then nl3 = ub3

Select Case TypeName(inputArray)
Case "Object()"
ReDim NewArray(1) As Object
Case "Boolean()"
ReDim NewArray(1) As Boolean
Case "Byte()"
ReDim NewArray(1) As Byte
Case "Currency()"
ReDim NewArray(1) As Currency
Case "Date()"
ReDim NewArray(1) As Date
Case "Double()"
ReDim NewArray(1) As Double
Case "Integer()"
ReDim NewArray(1) As Integer
Case "Long()"
ReDim NewArray(1) As Long
Case "Single()"
ReDim NewArray(1) As Single
Case "String()"
ReDim NewArray(1) As String
Case "Variant()"
ReDim NewArray(1) As Variant
Case Else
Msg = "#ERROR! Only built-in types of arrays are supported."
MsgBox Msg, 16
Exit Function
End Select

ReDim NewArray(lb1 To nlr - nfr + lb1, _
lb2 To nlc - nfc + lb2, _
lb3 To nl3 - nf3 + lb3)

'Load sub array
p = 0
q = 0
r = 0
If Not TypeName(inputArray) = "Object()" Then
For i = lb1 To nlr - nfr + lb1
For j = lb2 To nlc - nfc + lb2
For k = lb3 To nl3 - nf3 + lb3
NewArray(i, j, k) = inputArray(nfr + p, _
nfc + q, _
nf3 + r)
r = r + 1
Next
r = 0
q = q + 1
Next
r = 0
q = 0
p = p + 1
Next
Else
For i = lb1 To nlr - nfr + lb1
For j = lb2 To nlc - nfc + lb2
For k = lb3 To nl3 - nf3 + lb3
NewArray(i, j, k) = inputArray(nfr + p, _
nfc + q, _
nf3 + r)
r = r + 1
Next
r = 0
q = q + 1
Next
r = 0
q = 0
p = p + 1
Next
End If

SubArray3D = NewArray

End Function