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?
Alvast ontzettend bedankt.
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?
Code:
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.