Try this code.
In the test example the data is in the range A1: D4.
Function SwingArray(arr1 As Variant, _
colToTest As Long, _
StartCol As Long, _
Optional lDiscardLastCols As Long, _
Optional lMaxRows As Long = -1, _
Optional lMaxCols As Long = -1) As Variant
'takes one multi-column 2D array and swings the elements
'that have the same value in colToTest to the row where
'this value was found first. Column colToTest will only
'hold unique values in the resulting array.
'StartCol is the column where the copying of the elements
'starts from.
'--------------------------------------------------------
Dim arr2()
Dim arr3() 'As Long
Dim i As Long
Dim n As Long
Dim c As Long
Dim c2 As Long
Dim c3 As Long
Dim maxItems As Long
Dim uCo As Long
Dim LBR1 As Long
Dim UBR1 As Long
Dim LBC1 As Long
Dim UBC1 As Long
Dim tempIdx 'As Long
Dim arrError(0 To 0)
Dim bResumeNext As Boolean
On Error GoTo ERROROUT
LBR1 = LBound(arr1, 1)
UBR1 = UBound(arr1, 1)
LBC1 = LBound(arr1, 2)
UBC1 = UBound(arr1, 2) - lDiscardLastCols
'adjust UBR1 to account for empty elements
'these empty element have to be at the
'bottom of the array if they are there
'-----------------------------------------
For i = LBR1 To UBR1
If arr1(i, colToTest) = Empty And arr1(i, colToTest) <> 0 Then
UBR1 = i - 1
Exit For
End If
Next
ReDim arr3(LBR1 To UBR1) 'As Long
'find and mark the doubles
'get the maximum number of doubles
'---------------------------------
tempIdx = arr1(LBR1, colToTest)
For i = LBR1 + 1 To UBR1
If Not arr1(i, colToTest) = tempIdx Then
tempIdx = arr1(i, colToTest)
uCo = uCo + 1
c2 = 0
Else
arr3(i) = 1
c2 = c2 + 1
If c2 > maxItems Then
maxItems = c2
End If
End If
Next
'adjust the final array
'LBound will be as the original array
'------------------------------------
If lMaxRows = -1 And lMaxCols = -1 Then
ReDim arr2(LBR1 To uCo + LBR1, _
LBC1 To (UBC1) + maxItems * (((UBC1 + 1) - StartCol)))
Else
If uCo + LBR1 > lMaxRows And _
((UBC1) + maxItems * (((UBC1 + 1) - StartCol))) + (1 - LBC1) >
lMaxCols Then
ReDim arr2(LBR1 To lMaxRows - (1 - LBR1), LBC1 To lMaxCols - (1 -
LBC1))
bResumeNext = True
Else
If uCo + LBR1 > lMaxRows Then
ReDim arr2(LBR1 To lMaxRows - (1 - LBR1), _
LBC1 To (UBC1) + maxItems * (((UBC1 + 1) - StartCol)))
bResumeNext = True
Else
If ((UBC1) + maxItems * (((UBC1 + 1) - StartCol))) + (1 - LBC1) >
lMaxCols Then
ReDim arr2(LBR1 To uCo + LBR1, LBC1 To lMaxCols - (1 - LBC1))
bResumeNext = True
Else
ReDim arr2(LBR1 To uCo + LBR1, _
LBC1 To (UBC1) + maxItems * (((UBC1 + 1) - StartCol)))
End If
End If
End If
End If
n = LBR1 - 1
If bResumeNext Then
'to cover array OutofBounds errors
On Error Resume Next
End If
'swing the elements from vertical to horizontal
'----------------------------------------------
For i = LBR1 To UBR1
If Not arr3(i) = 1 Then
'copy first row in full
n = n + 1
For c = LBC1 To UBC1
arr2(n, c) = arr1(i, c)
Next
c3 = UBC1 + 1
Else
'copy subsequent rows from specified start column
'------------------------------------------------
For c = StartCol To UBC1
arr2(n, c3) = arr1(i, c)
c3 = c3 + 1
Next
End If
Next
SwingArray = arr2
Exit Function
ERROROUT:
arrError(0) = "ERROR"
SwingArray = arrError
End Function
Sub test()
Dim arr
Dim arr2
arr = Range(Cells(1), Cells(4, 4))
arr2 = SwingArray(arr, 1, 3)
Range(Cells(6, 1), Cells(UBound(arr2) + 5, UBound(arr2, 2))) = arr2
End Sub
I was using this on data where the first column of the array was holding
Long data, so I commented
out the Longs where needed.
RBS
