VBA+Access: Kruistabel maken met meer dan 255 kolommen (trage code)

[wiebeww]

Goedemorgen,

Ik probeer al enige tijd een kruistabel te maken echter lukt dit niet in Acces of Excel.

Met in totaal 9 miljoen records loop ik tegen problemen aan wanneer ik een kruistabel wil maken.
Als ik deze naar een kruistabel zou gieten krijg ik ongeveer 800 kolommen en 13.000 rijen.

Excel heeft de restrictie van 1,04 miljoen regels, Acces heeft de restrictie van ongeveer 250 kolommen.
Om dit te omzeilen heb ik onderstaande code gevonden (wellicht ook handig voor anderen hier).
(Ik heb wel nagedacht om minder data te gebruiken of alles op te knippen maar alle data is helaas echt nodig)

Nu wil het dat het 10 minuten duurt om 48 regels weg te schrijven (dataset is voor deze test 28.000 records).
Wanneer ik een grotere set neem duurt het 10(!) minuten om één regel weg te schrijven.

Ik heb geprobeerd om de VBA-module te compileren en er een .accde van te maken.

Weet iemand een alternatief voor deze code?
Of heeft één van jullie tips om deze code sneller te maken?

Function Kruistabel()

'Create File
    Dim CrossTabFile As String
    Dim stTableName As String
    Dim stColField As String
    Dim stColList As String
    
    Dim stRowList As String
    Dim stRowList2 As String
    Dim stValField As String
    Dim stValList As String
    Dim stWhere As String
    Dim stWhere2 As String
    Dim stAggFunction As String
        
    ' *****************************************  Change These Values As Needed *************************************
   
    Const myFilePath = "C:\Testmap"  ' don't forget to end with a slash \
    Const OutputFileName = "Test Kruistabel"
    Const OutNum As Integer = 2
    
    stTableName = Inputfile - Test Kruistabel"  ' Name of table to query
    stColField = "Component" ' Name of field to use as the column in crosstab
    stValField = "Code"    ' Name of field to use as the value in crosstab
    stAggFunction = "Max"    ' Aggregate function to perform on value field ( Example sum ,count, min, max )
    
    Const numFields = 2 'This is the number of row fields in your crosstab starting at 0 (0 = 1, 1 = 2, etc.)
    
    Dim arrRowFields(numFields) As String
    
    arrRowFields(0) = "Klant" ' Row Field 1
    arrRowFields(1) = "Groep"  ' Row Field 2
    arrRowFields(2) = "Product"  ' Row Field 2
    ' add more row fields as needed, increment the numFields too
    
    
' ********************************  Do not modify anything below this line  ************************************
    CrossTabFile = myFilePath & OutputFileName & ".csv"
    
    'Kill Previous File if Exists
    If FileExist(CrossTabFile) Then
        Kill (CrossTabFile)
    End If
    
    'Open File
    Open CrossTabFile For Append As OutNum

'Write Crosstab to File
    'Connection Variables
    Dim con As ADODB.Connection
    Dim rs1 As ADODB.Recordset
    Dim rs2 As ADODB.Recordset
    Dim rs3 As ADODB.Recordset
    Dim stSql1 As String
    Dim stSql2 As String
    Dim stSql3 As String
    
    'Get First Row
    Set con = Application.CurrentProject.Connection
    stSql1 = "SELECT distinct [" & stColField & "] FROM [" & stTableName & "];"
    Set rs1 = New ADODB.Recordset
    rs1.Open stSql1, con, 1
       
    Dim i As Integer
    For i = 0 To numFields
        stRowList = stRowList & arrRowFields(i) & ";"
        stRowList2 = stRowList2 & fieldBracket(arrRowFields(i)) & ","
    Next i
    
    If Not (rs1.EOF) Then
        Do While (Not (rs1.EOF))
            stColList = stColList & rs1(stColField) & ";"
            rs1.MoveNext
        Loop
    End If
    
    stColList = Left(stColList, Len(stColList) - 1)
    
    'Print out first row
    Print #OutNum, stRowList; stColList

    rs1.MoveFirst

'Write Values
    stRowList2 = Left(stRowList2, Len(stRowList2) - 1)
    stSql2 = "SELECT distinct " & stRowList2 & " FROM [" & stTableName & "];"
    Set rs2 = New ADODB.Recordset
    Set rs3 = New ADODB.Recordset
    
    rs2.Open stSql2, con, 1

    If Not (rs2.EOF) Then
        Do While (Not (rs2.EOF))
            stValList = ""
            stWhere = ""
            
            For i = 0 To numFields
                stValList = stValList & rs2.Fields(i) & ";"
                stWhere = stWhere & fieldBracket(rs2.Fields(i).Name) & " = " & getDeliminator(rs2.Fields(i).Type) & rs2.Fields(i) & getDeliminator(rs2.Fields(i).Type) & " AND "
            Next i
            
            If Not (rs1.EOF) Then
                Do While (Not (rs1.EOF))
                    stWhere2 = stWhere
                    stWhere2 = stWhere2 & fieldBracket(stColField) & " = " & getDeliminator(rs1(stColField).Type) & rs1(stColField) & getDeliminator(rs1(stColField).Type)
                    
                    stSql3 = "SELECT " & stAggFunction & "([" & stValField & "]) FROM [" & stTableName & "] where " & stWhere2
                    rs3.Open stSql3, con, 1
                    
                    If Not (rs3.EOF) Then
                        Do While (Not (rs3.EOF))
                            stValList = stValList & rs3.Fields(0) & ";"
                            rs3.MoveNext
                        Loop
                    End If
                    rs1.MoveNext
                    
                    rs3.Close
                Loop
            End If
                            
                            
            Print #OutNum, Left(stValList, Len(stValList) - 1)
            rs1.MoveFirst
            rs2.MoveNext
        Loop
    End If
            rs1.Close
            rs2.Close

'Cleanup
    Set rs1 = Nothing
    Set con = Nothing
    
    'Close File
    Close #OutNum
End Function

Alvast ontzettend bedankt.