Multidimensionale array transponeren en in range weergeven

[johhnnyboy]

Hoi,

In de bijlage heb ik mijn test bestandje opgenomen met mijn huidige VBA code.
De bedoeling is dat op basis van kolom B waarde "4", de waarde uit kolom A naar kolom D wordt overgenomen.
Hierbij wordt in kolom E dan een 6-tal productcodes weergegeven.
Vanuit het Excelbestand wordt de bedoeling wel duidelijk. De gewenste output heb ik daar in kolom D en E weergegeven.

Nu ben ik een eindje op weg met de macro. Ik had eerst een 1 dimensionale array waarvoor de code werkte.
Nu ben ik deze aan het ombouwen naar 2 dimensies, maar krijg nu de foutmelding "subscript valt buiten bereik" bij

ReDim Preserve ArrayProducten(0 To UBound(ArrayProducten) + 1, 6)

Heeft iemand suggesties?

 

[snb]

Zou autofilter niet voor-de-hand-liggender zijn ?

 

[johhnnyboy]

Redim preserve

'k Heb inmiddels de oplossing. Het schijnt dat een multidimensionale array niet via redim preserve kan worden geset.
De code om dit op te lossen:

Public Function ReDimPreserve(aArrayToPreserve, nNewFirstUBound, nNewLastUBound)
    ReDimPreserve = False
    'check if its in array first
    If IsArray(aArrayToPreserve) Then
        'create new array
        ReDim aPreservedArray(nNewFirstUBound, nNewLastUBound)
        'get old lBound/uBound
        nOldFirstUBound = UBound(aArrayToPreserve, 1)
        nOldLastUBound = UBound(aArrayToPreserve, 2)
        'loop through first
        For nFirst = LBound(aArrayToPreserve, 1) To nNewFirstUBound
            For nLast = LBound(aArrayToPreserve, 2) To nNewLastUBound
                'if its in range, then append to new array the same way
                If nOldFirstUBound >= nFirst And nOldLastUBound >= nLast Then
                    aPreservedArray(nFirst, nLast) = aArrayToPreserve(nFirst, nLast)
                End If
            Next
        Next
        'return the array redimmed
        If IsArray(aPreservedArray) Then ReDimPreserve = aPreservedArray
    End If
End Function

 

[Warme bakkertje]

Een multidimensionale array kan wel geherdimensioneerd worden, ook met preserve, , maar enkel de 2de dimensie

 

[snb]

Volgens mij voer jij alleen een transpose op de array uit:

sn=cells(1).currentregion
msgbox ubound(sn) & vbtab & ubound(sn,2)

sp =application.transpose(sn)
msgbox ubound(sp) & vbtab & ubound(sp,2)