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

[jkpieterse]

Even om de discussie wat te triggeren (en omdat ik geen tijd heb om het zelf te testen):

Het maken van lange strings is in VBA (erg) inefficient, dus al dat gedoe met split en join e.d. komt mij voor als zijnde een trage oplossing (al kan je wel lekker korte code schrijven).
Is het niet (veel) sneller om de hele currentregion in een variant array te laden en ermee klaar te zijn? Als je dan de data wilt gebruiken simpel testen op isempty?

 

[snb]

@JKP

Lange strings zijn sinds #6 allang verlaten.

 

[E v R]

Nog een combinatie van diverse vba code uit dit draadje en waarbij het aantal kolommen niet meer keihard in de code hoeft te worden gezet.
kan wellicht nog wat efficiënter en ook toegepast worden op de collectie en dictionary

Sub ttt()
    Dim z(1, 1) As Variant, y As Long, i As Long, j As Long, rng As Range, x As Long, dc As String
    Set rng = Cells(3, 1).CurrentRegion
    ReDim sn(rng.Columns.Count - 1)
    
    y = 1
    For j = 0 To UBound(sn)
        If rng.Columns(j + 1).SpecialCells(2).Count = 1 Then
            z(1, 1) = rng.Columns(j + 1).SpecialCells(2).Value
            sn(j) = z
        Else
            sn(j) = rng.Columns(j + 1).SpecialCells(2)
        End If
        
        If Not IsArray(sn(j)) Then sn(j) = Split(sn(j))
        y = y * Application.Max(1, UBound(sn(j)))
    Next
  
'----  
    ReDim sp(y - 1, 0)
   
    For j = 0 To y - 1
     x = 1
        For i = 0 To UBound(sn)
            If i > 0 Then
                 dc = ";"
             Else
                 dc = ""
            End If
                x = x * UBound(sn(i))
                sp(j, 0) = sp(j, 0) & dc & sn(i)((Application.Quotient(j, y / x) + 1) Mod UBound(sn(i)) + 1, 1)
        Next i
    Next j
   '--------- 
   ActiveSheet.Cells(1, 10).Resize(y) = sp
 End Sub

 

[snb]

Ik ben nog even doorgegaan op de sugggestie van Alphamax.
De resultaten zijn - inherent aan de methode - niet in 5040 tekenreeksen ondergebracht, maar in een gebied van 5040 rijen * 8 kolommen
Dat geld ook voor de "DAO" aanpak die ik vervolgens maakte.
Over de snelheid heb ik niets te klagen.

Uiteindelijk kwam ik op deze code voor een Querytable

Sub M_snb()
  For Each it In Sheet1.Cells(1).CurrentRegion.Columns
    it.SpecialCells(2).Name = it.Cells(1).Value
    c00 = c00 & "," & it.Cells(1).Value
  Next
  
  Sheet1.QueryTables.Add("ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName & ";", Cells(1, 10), "SELECT * FROM " & Mid(c00, 2)).Refresh
End Sub

De 'DAO'-aanpak:

Sub M_snb()
  For Each it In Sheet1.Cells(1).CurrentRegion.Columns
    it.SpecialCells(2).Name = it.Cells(1).Value
    c00 = c00 & "," & it.Cells(1).Value
  Next
    
  With CreateObject("ADODB.Recordset")
    .Open "SELECT * FROM  " & Mid(c00, 2) & "", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml"""
    Sheet1.Cells(1, 10).CopyFromRecordset .DataSource
  End With
End Sub

 

[Ginger]

[/QUOTE]Whoops, sorry Alphamax. Ik had jouw post met een pracht code op "Database niveau" gemist. Ook dit is weer een fijn exemplaar in het rijtje. :thumb:
Nooit gedacht dat mijn vraag zoveel stof zou doen opwaaien en vooral zulke mooie resultaten zou opleveren.

 

[Ginger]

Nog een combinatie...

EvR, ik moet 'm thuis nog gaan uitproberen. Maar ook deze neem ik mee in de studie. Dank hiervoor.

 

[snb]

Ik vond je al zo koeltjes tegenover Alphamax ...

 

[Ginger]

Ik ben nog even doorgegaan...

Ha ha ha... snb "The unstoppable"! :thumb:

Van lieverlee voel ik me weer kleiner en kleiner worden. Dit zijn echt oplossingen van formaat moet ik zeggen (en vrees ook van een niveau dat ik niet meer bereik). Maar laat je vooral niet tegenhouden zolang je het nog leuk vindt.

 

[Ginger]

Ik vond je al...

Ha ha ha... Dit is "dankbaarheid achteraf", maar vooral niet minder gemeend.

 

[E v R]

Mooie oplossingen Alphamax en snb!! :thumb::thumb:

 

[alphamax]

Dank je, ik begin "databases" en SQL steeds leuker te vinden.

 

[snb]

Dan nog een hulpvraag.

Zoals je kunt zien in de code van Alpha en mij worden er eerst gebieden ('velden') benoemd waarnaar in de SQL tekenreeks verwezen wordt.
Als we in Excel van de gegevens een Tabel (VBA: listobject) zouden maken, zou het in principe mogelijk moeten zijn direkt naar die 'velden' per kolom te verwijzen (net als in een formule in het werkblad). Hoe zouden die verwijzingen in de SQL-tekenreeks dan gefomuleerd moeten worden ? Dan zouden we nl. de tussenstap van benoemde gebieden kunnen overslaan.

 

[Ginger]

@allen, ik heb de vraag weer even open gezet. Hij loopt nog zo mooi door!

 

[alphamax]

Elke named range in excel is voor sql een unieke tabel.
Dat is wat anders dan de "structured reference" in een listobject.

 

[alphamax]

maak een tabel/listobject en de werkt domweg

.Open "SELECT * FROM [product],[formaat],[bedrukking]", "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml"""

 

[snb]

@Alpha,

Dank; Ook als je eerst alle named ranges verwijdert ?

 

[alphamax]

[SIZE=1]Option Explicit

Public Sub CombinationJaggedArray_Range2()    'alphamax_2016
    Dim strConnection As String
    Dim strSQL As String
    On Error Resume Next
    ListObjects.Add(xlSrcRange, Cells(1).CurrentRegion, , xlYes).Name = "Table1"
    strConnection = "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName & ";"
    strSQL = "SELECT * FROM " & "[" & Join(Application.Index(ListObjects("Table1").HeaderRowRange.Value, 1, 0), "],[") & "];"
    QueryTables.Add(strConnection, Range("J1"), strSQL).Refresh
End Sub[/SIZE]

 

[snb]

Zonder named ranges geen succes:

Public Sub CombinationJaggedArray_Range2()    'alphamax_2016
    Dim strConnection As String
    Dim strSQL As String

    For Each it In Names
       it.Delete
    Next

    On Error Resume Next
    ListObjects.Add(xlSrcRange, Cells(1).CurrentRegion, , xlYes).Name = "Table1"
    
    On Error GoTo 0
    strConnection = "ODBC;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName & ";"
    strSQL = "SELECT * FROM [" & Join(Application.Index(ListObjects("Table1").HeaderRowRange.Value,1,0),"],[") & "];"
    QueryTables.Add(strConnection, Range("J1"), strSQL).Refresh
End Sub

 

[Ginger]

@Alpa, @snb, Bij mij doet de laatste code van Alpha het niet. Als ik de On Error Resume Next even uitster, krijg ik de melding dat er op de volgende regel een object nodig is. Als ik daar "Activesheet." voor de Listobject plaats, loopt de code wel door en wordt de tabel aangemaakt.
Helaas loopt de code daarna dan vast op de regel...

strSQL = "SELECT * FROM " & "[" & Join(Application.Index(ListObjects("Table1").HeaderRowRange.Value, 1, 0), "],[") & "];"

...met een Runtime Error 13 (Type Mismatch) melding. En dan schiet mijn kennis - zoals eerder gezegd - zwaar te kort.

[EDIT] Hetzelfde euvel bij de code van snb.

Mis ik een bepaalde reference ofzo?

 

[alphamax]

misschien is het dan toch te mooi om waar te zijn?