Обработка одномерного динамического массива

Option Explicit
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Type DetailIdentity
A_Name As String
B_Designation As String
C_Accessory As String
D_Number As String
E_Count As Integer
End Type
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Sub aha()

Dim a As Variant
a = Array( _
"detail_31", "desc_31", "access_11", "num_11", _
"detail_21", "desc_21", "access_21", "num_21", _
"detail_41", "desc_41", "access_41", "num_41", _
"detail_11", "desc_11", "access_11", "num_11", _
"detail_11", "desc_11", "access_11", "num_11", _
"detail_31", "desc_31", "access_31", "num_31", _
"detail_31", "desc_31", "access_31", "num_31", _
"detail_21", "desc_21", "access_21", "num_21", _
"detail_41", "desc_41", "access_41", "num_41", _
"detail_31", "desc_31", "access_31", "num_31", _
"detail_11", "desc_11", "access_11", "num_11")
Dim b() As DetailIdentity
Call CountDetails(b, a, 4)

End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'

Private Sub CountDetails(ByRef DetailIdentities() _
As DetailIdentity, ByVal Source As Variant, ByVal num As Integer)

Dim Item As Variant
Dim i As Integer, j As Integer, k As Integer

ReDim DetailIdentities(0) As DetailIdentity
For i = 0 To UBound(Source) Step num
ReDim Preserve DetailIdentities(k) As DetailIdentity
DetailIdentities(UBound(DetailIdentities)).A_Name = Source(i)
DetailIdentities(UBound(DetailIdentities)).B_Designation = Source(i + 1)
DetailIdentities(UBound(DetailIdentities)).C_Accessory = Source(i + 2)
DetailIdentities(UBound(DetailIdentities)).D_Number = Source(i + 3)
DetailIdentities(UBound(DetailIdentities)).E_Count = 0
k = k + 1
Next i

For i = 0 To UBound(Source) Step num
Item = Source(i)
For j = LBound(DetailIdentities) To UBound(DetailIdentities)
If Item = DetailIdentities(j).A_Name Then
DetailIdentities(j).E_Count = DetailIdentities(j).E_Count + 1
End If
Next j
Next i

Dim Coll As Collection
Set Coll = New Collection
For j = LBound(DetailIdentities) To UBound(DetailIdentities)
Dim tmp(4) As Variant
tmp(0) = DetailIdentities(j).A_Name
tmp(1) = DetailIdentities(j).B_Designation
tmp(2) = DetailIdentities(j).C_Accessory
tmp(3) = DetailIdentities(j).D_Number
tmp(4) = DetailIdentities(j).E_Count
On Error Resume Next
Coll.Add Item:=tmp, key:=CStr(tmp(1))
Next j
j = 0
Dim elem
For Each elem In Coll
ReDim Preserve DetailIdentities(0 To j) As DetailIdentity
DetailIdentities(j).A_Name = elem(0)
DetailIdentities(j).B_Designation = elem(1)
DetailIdentities(j).C_Accessory = elem(2)
DetailIdentities(j).D_Number = elem(3)
DetailIdentities(j).E_Count = elem(4)
j = j + 1
Next
Debug.Print "Name" & vbTab & "Count" & vbCr & "|____________________|"
j = 0
For i = LBound(DetailIdentities) To UBound(DetailIdentities)
Debug.Print DetailIdentities(i).A_Name & vbTab & DetailIdentities(i).E_Count
j = j + CInt(DetailIdentities(i).E_Count)
Next i
Debug.Print "|____________________|" & vbCr & "Total: " & j
End Sub

Option Explicit
' see also:
'  http://forum.developing.ru/showthread.php?p=53799#post53799
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. (c)2006 * all rights removed '
' SourceArr - two dimensional array ' двухмерный массив
' iPos - "column" number (starting from 1) ' физический номер столбца
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function CoolSort(SourceArr As Variant, iPos As Integer) As Variant

Dim Check As Boolean
ReDim tmpArr(UBound(SourceArr, 2)) As Variant
Dim iCount As Integer
Dim jCount As Integer
Dim nCount As Integer

iPos = iPos - 1
Check = False

Do Until Check
Check = True
For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
If SourceArr(iCount, iPos) > SourceArr(iCount + 1, iPos) Then
For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
tmpArr(jCount) = SourceArr(iCount, jCount)
SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
SourceArr(iCount + 1, jCount) = tmpArr(jCount)
Check = False
Next
End If
Next
Loop

CoolSort = SourceArr

End Function
' usage example
Sub AA1()
ReDim ar(2, 3) As String
ar(0, 0) = "Cabinet1": ar(0, 1) = "Y-Total1": ar(0, 2) = "x1": ar(0, 3) = "Stud 1"
ar(1, 0) = "Cabinet1": ar(1, 1) = "Y-Total1": ar(1, 2) = "x3": ar(1, 3) = "Stud 1"
ar(2, 0) = "Cabinet1": ar(2, 1) = "Y-Total1": ar(2, 2) = "x2": ar(2, 3) = "Stud 1"
Dim res, i, j, msg As String
res = CoolSort(ar, 3)
msg = ""
For i = 0 To UBound(res, 1)
For j = 0 To UBound(res, 2)
msg = msg & " | " & res(i, j) & " | "
Next
msg = msg & vbCr
Next
MsgBox msg
End Sub

Sub Test()
Dim i As Long, j As Long
Dim newar As Variant
Dim arr(10, 3) As Integer
For i = 0 To 9
For j = 0 To 3
arr(i, j) = (-1 * i) ^ j
Next
Next
newar = CoolSort(arr, 2)

End Sub