• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Jagged Array (array met array's) met 1 element in zo'n array van een array [VBA]

Status
Niet open voor verdere reacties.
Ginger

Ginger

Terugkerende gebruiker
Lid geworden
29 dec 2006
Berichten
2.972
Helpers. nav een vraag was ik me gaan verdiepen in zogenaamde jagged array's (= geneste array's). In de bijlage zie je de opzet van 8 kolommen met elk een ongelijke hoeveelheid aan gegevens (in het echte document is het een veelvoud van blokken met gegevens waar doorheen gelust wordt). De vraag was om al deze gegevens van het blok in combinaties te zetten. Hierom bedacht ik dus om te gaan werken met jagged array's. Nu loop ik tegen het vervelende ding aan dat het kan dat een kolom slechts 1 gegeven bevat. Hierdoor wordt bij het aanmaken van de jagged array dat element van de "hoofd array" geen array type maar een string type.
Bij het samen voegen als string....
Code: 
        OutputArr(x) = Join(Array(arr(1)(i1, 1), _                                  
                                  arr(2)(i2, 1), _
                                  arr(3)(i3, 1), _
                                  arr(4)(i4, 1), _
                                  arr(5)(i5, 1), _
                                  arr(6)(i6, 1), _
                                  arr(7)(i7, 1), _
                                  arr(8)(i8, 1)), ";")
...loopt het dus spaak (runtime error 13; type mismatch) bij het eerste element (arr(1)(i1, 1))omdat dat geen array is.
[DE VRAAG:] HOE kan ik er nog voor zorgen dat elk element van de hoofdarray een array is? Ook al bevat deze dus maar slechts 1 element?

Het weglaten van dat eerste element is geen optie omdat het nu bij de eerste is, maar kan bij elke kolom voor komen. En even voor de goede orde... Volgens mij moet dit op te lossen zijn met een collection of met een dictionary, maar da's in dit geval niet de vraag. ;)
 

Bijlagen

Laatst bewerkt:
Aan de voorkant oplossen? Dus wanneer het 1 cel betreft dit schrijven naar een 2-dimensionale array en deze toewijzen?

Code: 
'.........
    Dim z(1, 1) As Variant
    Cells(3, 1).Select ' dit is alleen even voor de versie op Helpmij.NL
    
    ArrSize = 1
    Set rng = ActiveCell.CurrentRegion
    ' vul de array met arrays
    For col = 1 To 8
    If rng.Columns(col).SpecialCells(xlCellTypeConstants).Count = 1 Then
    z(1, 1) = rng.Columns(col).SpecialCells(xlCellTypeConstants).Value
   arr(col) = z
       Else
    arr(col) = rng.Columns(col).SpecialCells(xlCellTypeConstants)
    End If
    
       
        If IsArray(arr(col)) Then 
'............
 
Ik dacht zó:

Code: 
Sub M_snb()
    Set rng = Cells(3, 1).CurrentRegion
    ReDim sn(rng.Columns.Count - 1)
    
    For j = 0 To UBound(sn)
        sn(j) = rng.Columns(j + 1).SpecialCells(2)
        If Not IsArray(sn(j)) Then sn(j) = Split(sn(j))
    Next
    
    For Each it0 In sn(0)
      For Each it1 In sn(1)
        For Each it2 In sn(2)
          For Each it3 In sn(3)
            For Each it4 In sn(4)
              For Each it5 In sn(5)
                For Each it6 In sn(6)
                  For Each it7 In sn(7)
                     c00 = c00 & vbLf & Join(Array(it0, it1, it2, it3, it4, it5, it6, it7, it8), ";")
                  Next
                Next
              Next
            Next
          Next
        Next
      Next
    Next
    sp = Split(Mid(c00, 2), vbLf)

   ActiveSheet.Cells(1, 10).Resize(UBound(sp) + 1) = Application.Transpose(sp)
End Sub
 
Laatst bewerkt:
@EvR, Dank voor je reactie. Jouw oplossing had ik ook bedacht én toegepast. Vreemd genoeg ziet VBA het bij het samenvoegen van de string dat dan als een Variant/String type en knalt alsnog (tenminste.. bij de tests die ik had uitgevoerd).

@snb, Dank voor je reactie. En tja... Hierin herkent met weer de oude rot in het vak. De Guru! Waarom moeilijk doen met tellers als je een For Each kan gebruiken voor het samenstellen van de string. Die Split bij het opbouwen van de jagged Array had ik ook al gevonden, maar liep daarmee dus ook vast in de opbouw van de string. Maar door de sting gelijk de waarde terug te geven via For Each ipv het uitvragen van de array is vééééééél slimmer. Hier heb ik dus een avondje op zitten puzzelen. Leuk dat jij het er zo ff uit ramt. :D :thumb:

Beide nogmaals super dank voor de geboden oplossingen. Ik kan weer verder.
 
Ben benieuwd waar en hoe het mis ging in jouw tests ( in jouw aangedragen voorbeeld werkt het mi prima ;) )

Verbaasde me al dat mijn reaktie eerder was dan de totaal-oplossing van snb :d :thumb: ( hoewel jouw initiële code vele malen sneller is )

+ die Join(array( lijkt ook wat overdreven om er enkel ";" tussen te zetten, maar of daar tijdswinst in zit geen idee
 
Laatst bewerkt:
@E V R

de tekstreeks c00 wordt toch wel erg groot.

Code: 
Sub M_snb()
    Set rng = Cells(3, 1).CurrentRegion
    ReDim sn(rng.Columns.Count - 1)
    
    y = 1
    For j = 0 To UBound(sn)
        sn(j) = rng.Columns(j + 1).SpecialCells(2)
        If Not IsArray(sn(j)) Then sn(j) = Split(sn(j))
        y = y * rng.Columns(j + 1).SpecialCells(2).Count
    Next
    ReDim sp(y, ubound(sn))
    
    y = 0
    For Each it0 In sn(0)
      For Each it1 In sn(1)
        For Each it2 In sn(2)
          For Each it3 In sn(3)
            For Each it4 In sn(4)
              For Each it5 In sn(5)
                For Each it6 In sn(6)
                  For Each it7 In sn(7)
                     sp(y, 0) = it0
                     sp(y, 1) = it1
                     sp(y, 2) = it2
                     sp(y, 3) = it3
                     sp(y, 4) = it4
                     sp(y, 5) = it5
                     sp(y, 6) = it6
                     sp(y, 7) = it7
                     y = y + 1
                  Next
               Next
            Next
          Next
        Next
      Next
    Next
    Next

   ActiveSheet.Cells(1, 10).Resize(y, ubound(sp,2)+1) = sp
End Sub

Als een kolom slechts uit 1 waarde bestaat maakt VBA er automatisch een string van. Dan is dat element van de array dus niet gevuld met een array maar met een string. Dat los ik op door in zo'n geval 'split' te gebruiken.
 
Laatst bewerkt:
@snb
Top! al een stuk sneller

met dezelfde output als in post #1
Code: 
Set rng = Cells(3, 1).CurrentRegion
    ReDim sn(rng.Columns.Count - 1)
    
    y = 1
    For j = 0 To UBound(sn)
        sn(j) = rng.Columns(j + 1).SpecialCells(2)
        If Not IsArray(sn(j)) Then sn(j) = Split(sn(j))
        y = y * (UBound(sn(j)) + 1)
    Next
    ReDim sp(y)
    
    y = 0
    For Each it0 In sn(0)
      For Each it1 In sn(1)
        For Each it2 In sn(2)
          For Each it3 In sn(3)
            For Each it4 In sn(4)
              For Each it5 In sn(5)
                For Each it6 In sn(6)
                  For Each it7 In sn(7)
                     sp(y) = it0 & ";" & it1 & ";" & it2 & ";" & it3 & ";" & it4 & ";" & it5 & ";" & it6 & ";" & it7
                     y = y + 1
                  Next
               Next
            Next
          Next
        Next
      Next
    Next
    Next

   ActiveSheet.Cells(1, 10).Resize(UBound(sp)) = Application.Transpose(sp)
 
dan ook maar zonder transpose:

Code: 
    Set rng = Cells(3, 1).CurrentRegion
    ReDim sn(rng.Columns.Count - 1)
    
    y = 1
    For j = 0 To UBound(sn)
        sn(j) = rng.Columns(j + 1).SpecialCells(2)
        If Not IsArray(sn(j)) Then sn(j) = Split(sn(j))
        y = y * (UBound(sn(j)) + 1)
    Next
    ReDim sp(y,0)
    
    y = 0
    For Each it0 In sn(0)
      For Each it1 In sn(1)
        For Each it2 In sn(2)
          For Each it3 In sn(3)
            For Each it4 In sn(4)
              For Each it5 In sn(5)
                For Each it6 In sn(6)
                  For Each it7 In sn(7)
                     sp(y,0) = it0 & ";" & it1 & ";" & it2 & ";" & it3 & ";" & it4 & ";" & it5 & ";" & it6 & ";" & it7
                     y = y + 1
                  Next
               Next
            Next
          Next
        Next
      Next
    Next
    Next

   ActiveSheet.Cells(1, 10).Resize(y) = sp
 
Wowwwwww.... Effe stiekem "tussendoor" gekeken op Helpmij. Zie ik dat EvR en snb "gewoon" nog lekker doorgaan met het ontwikkelen... Ha ha ha... Toppers! Vanavond ga ik jullie reacties bestuderen en zal ik terugkoppelen. Moet ik nu op mijn werk maar niet gaan doen. :D
 
@EvR, nav postnr.2....
mea culpa,
mea culpa,
mea maxima culpa.

Mijn oprechte verontschuldiging. Ik was TE snel met reageren naar je. Wat jij doet, "leek" hetzelfde als wat ik had gedaan. Maar met het verschil dat ik dus éérst die Variant/String type liet aanmaken. Vervolgens liet controleren of het een array was (niet dus) om daarna NOGMAALS via die extra vooraf gedefinieerde array - van 1 element groot - deze te koppelen aan de "hoofdarray". Het blijkt dus dat dan het type niet meer wordt aangepast. Met jouw aanpassing loopt het als een speer!!! Dank dus voor deze oplossing die in de lijn van mijn gedachtegang zat.
 
@snb, Je procedure in postnr.8 is inderdaad helemaal top. Razendsnel! Het is een andere lijn dan ik had ingezet, wat het alleen maar véél gaver maakt. Om te verzinnen - voor mij - is duidelijk een stap te ver. Maar als leerdoel super gaaf. Dank hiervoor.
 
@Ginger

Goed zo !.
Waarschijnljk ga jij (gezien de info in #1) gebruik maken van areas ?

Nog even een alternatief met een Dictionary (reduceert het aantal hulpvariabelen).

Code: 
Sub M_snb()
  Set rng = Cells(3, 1).CurrentRegion
  ReDim sn(rng.Columns.Count - 1)
    
  For j = 0 To UBound(sn)
    sn(j) = rng.Columns(j + 1).SpecialCells(2)
    If Not IsArray(sn(j)) Then sn(j) = Split(sn(j))
  Next
    
  With CreateObject("scripting.dictionary")
    For Each it0 In sn(0)
      For Each it1 In sn(1)
        For Each it2 In sn(2)
          For Each it3 In sn(3)
            For Each it4 In sn(4)
              For Each it5 In sn(5)
                For Each it6 In sn(6)
                  For Each it7 In sn(7)
                     x0 = .Item(it0 & ";" & it1 & ";" & it2 & ";" & it3 & ";" & it4 & ";" & it5 & ";" & it6 & ";" & it7)
                  Next
                Next
              Next
            Next
          Next
        Next
      Next
    Next

    ActiveSheet.Cells(1, 10).Resize(.Count) = Application.Transpose(.keys)
  End With
End Sub
 
@snb, Hier ben ik je héél dankbaar voor. Een versie met de Dict is voor mij weer een puzzel (hoe vaak en hoe goed jij ook je best hebt gedaan om deze kennis over te dragen aan mij). Maar dus wel weer een mooie oefening voor mij om 'm te doorgronden. Super!
 
Voor de volledigheid dan ook maar met het gebruik van een Collection.

Kun je alledrie methoden met elkaar vergelijken.

Code: 
Sub M_snb_coll()
  Set rng = ActiveSheet.Cells(3, 1).CurrentRegion
  ReDim sn(rng.Columns.Count - 1)
    
  For j = 0 To UBound(sn)
    sn(j) = rng.Columns(j + 1).SpecialCells(2)
    If Not IsArray(sn(j)) Then sn(j) = Split(sn(j))
  Next
    
  With New Collection
    For Each it0 In sn(0)
      For Each it1 In sn(1)
        For Each it2 In sn(2)
          For Each it3 In sn(3)
            For Each it4 In sn(4)
              For Each it5 In sn(5)
                For Each it6 In sn(6)
                  For Each it7 In sn(7)
                     .Add it0 & ";" & it1 & ";" & it2 & ";" & it3 & ";" & it4 & ";" & it5 & ";" & it6 & ";" & it7
                  Next
                Next
              Next
            Next
          Next
        Next
      Next
    Next
   
    For j = 1 To .Count
       ActiveSheet.Cells(j, 10) = .Item(j)
    Next
  End With
End Sub
 
@snb. Top! Tnx. Dat levert een mooi compleet plaatje op zo. :D
 
@Ginger

Nog iets anders: dit lijkt de snelste variant; weliswaar zonder een kartelige (jagged) array.

Code: 
Sub M_snb_arr_0()
  ReDim sp(0)
  sn = Cells(3, 1).CurrentRegion
    
  For j_1 = 1 To UBound(sn)
    If sn(j_1, 1) = "" Then Exit For
    For j_2 = 1 To UBound(sn)
      If sn(j_2, 2) = "" Then Exit For
      For j_3 = 1 To UBound(sn)
        If sn(j_3, 3) = "" Then Exit For
        For j_4 = 1 To UBound(sn)
          If sn(j_4, 4) = "" Then Exit For
          For j_5 = 1 To UBound(sn)
            If sn(j_5, 5) = "" Then Exit For
            For j_6 = 1 To UBound(sn)
              If sn(j_6, 6) = "" Then Exit For
              For j_7 = 1 To UBound(sn)
                If sn(j_7, 7) = "" Then Exit For
                For j_8 = 1 To UBound(sn)
                  If sn(j_8, 8) = "" Then Exit For
                  sp(UBound(sp)) = sn(j_1, 1) & ";" & sn(j_2, 2) & ";" & sn(j_3, 3) & ";" & sn(j_4, 4) & ";" & sn(j_5, 5) & ";" & sn(j_6, 6) & ";" & sn(j_7, 7) & ";" & sn(j_8, 8)
                  ReDim Preserve sp(UBound(sp) + 1)
                Next
              Next
            Next
          Next
        Next
      Next
    Next
  Next

  ActiveSheet.Cells(1, 10).Resize(UBound(sp) + 1) = Application.Transpose(sp)
End Sub
 
Ha ha ha... dit in het idee van "er leiden véle wegen naar Rome"? LOL :D

Wel weer heel goed gevonden om gewoon door alle kolommen heen te gaan en de "sub lus" te verlaten als deze leeg is.
 
Ja maar erg mooi vind ik het niet; dus dan maar deze variant (ten koste van 1 extra array):

Code: 
Sub M_snb_arr_0()
    ReDim sp(0)
    ReDim st(8)
    With Cells(3, 1).CurrentRegion
      sn = .Value
      For j = 1 To 8
        st(j) = .Columns(j).SpecialCells(2).Count
      Next
    End With
    
    For j_1 = 1 To st(1)
      For j_2 = 1 To st(2)
        For j_3 = 1 To st(3)
          For j_4 = 1 To st(4)
            For j_5 = 1 To st(5)
              For j_6 = 1 To st(6)
                For j_7 = 1 To st(7)
                  For j_8 = 1 To st(8)
                     sp(UBound(sp)) = sn(j_1, 1) & ";" & sn(j_2, 2) & ";" & sn(j_3, 3) & ";" & sn(j_4, 4) & ";" & sn(j_5, 5) & ";" & sn(j_6, 6) & ";" & sn(j_7, 7) & ";" & sn(j_8, 8)
                     ReDim Preserve sp(UBound(sp) + 1)
                  Next
                Next
              Next
            Next
          Next
        Next
      Next
    Next

    ActiveSheet.Cells(1, 10).Resize(UBound(sp) + 1) = Application.Transpose(sp)
End Sub
 
Code: 
[SIZE=1]Option Explicit

Public Sub CombinationJaggedArray_Range() 'alphamax_2016
    Dim objColumn As Object
    Dim strConnection As String
    Dim strSQL As String
        On Error Resume Next
        ActiveWorkbook.Connections(1).Delete
        Range("J1").CurrentRegion.Clear
        With Range("A1").CurrentRegion
            For Each objColumn In .Columns
                With objColumn
                    .Cells(1).Resize(.SpecialCells(2).Count).Name = .Cells(1).Value
                End With
            Next
            strConnection = "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName & ";"
            strSQL = "SELECT * FROM " & Join(Application.Index(.Value, 1), ", ") & ";"
            QueryTables.Add(strConnection, Range("J1"), strSQL).Refresh
        End With
End Sub[/SIZE]
 

Bijlagen

Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan