In mijn tabel een kolom met datum, kolom met naam en een aantal kolommenn met scores.
Nu kan eenzelfde naam meermaals voorkomen op een bepaalde datum.
Graag wil ik dan deze rijen samenvoegen in één rij, en de scores optellen.
bron
datum naam score
01-01 piet 1
01-01 jan 5
01-01 piet 10
01-01 piet 9
02-01 piet 2
02-01 jan 4
02-01 jan 1
resultaat
01-01 piet 20
01-01 jan 5
02-01 piet 2
02-01 jan 5
Ik heb hiervoor zowel een werkende formule en VBA code.
VBA heeft mijn voorkeur omdat het bestand door anderen gebruikt gaat worden en er per maand ruim 1000 regels bijkomen.
Dit is meteen mijn probleem; het sorteren met mijn VBA code neemt veel tijd in beslag.
Wie o wie kan mij helpen het samenvoegen te versnellen?
Alvast bedankt!
Voorbeeld met VBA in bijlage:
Bekijk bijlage samenvoegen.xlsm
Nu kan eenzelfde naam meermaals voorkomen op een bepaalde datum.
Graag wil ik dan deze rijen samenvoegen in één rij, en de scores optellen.
bron
datum naam score
01-01 piet 1
01-01 jan 5
01-01 piet 10
01-01 piet 9
02-01 piet 2
02-01 jan 4
02-01 jan 1
resultaat
01-01 piet 20
01-01 jan 5
02-01 piet 2
02-01 jan 5
Ik heb hiervoor zowel een werkende formule en VBA code.
VBA heeft mijn voorkeur omdat het bestand door anderen gebruikt gaat worden en er per maand ruim 1000 regels bijkomen.
Dit is meteen mijn probleem; het sorteren met mijn VBA code neemt veel tijd in beslag.
Wie o wie kan mij helpen het samenvoegen te versnellen?
Alvast bedankt!
Code:
Public Sub MaaktotaalSQL()
'sorteren en optellen bij dubbele gebruikersgegevens op dezelfde datum
Dim rs As ADODB.Recordset
Dim cn As ADODB.Connection
Dim vSQLText As String
Set cn = New ADODB.Connection
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source= " & ActiveWorkbook.Path & "\" & _
ActiveWorkbook.Name & ";" & _
"Extended Properties=Excel 8.0;"
.Open
End With
On Error GoTo Queryfout
vSQLText = "SELECT datum, naam, SUM(score1), SUM(score2), SUM(score3), SUM(totaal) as Waarde FROM [Invoer$] " & _
"GROUP BY datum, naam;"
Set rs = New ADODB.Recordset
rs.Open vSQLText, cn, adOpenDynamic, adLockReadOnly
rs.MoveLast
rs.MoveFirst
Application.ScreenUpdating = 0
Sheets("Database").Select
Range("B1").Select
Do While Not rs.EOF
For nTeller = 1 To rs.Fields.Count
ActiveCell.Offset(0, nTeller - 1) = rs.Fields(nTeller - 1)
Next
ActiveCell.Offset(1, 0).Select
rs.MoveNext
Loop
Dim FirstRow As Long
FirstRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
ActiveSheet.Cells(FirstRow + 1, "A").Value = ActiveSheet.Cells(FirstRow, "A").Value + 1
Set rs = Nothing
Set cn = Nothing
Exit Sub
Queryfout:
Select Case Err.Number
Case 3021
If rs.RecordCount = 0 Then
MsgBox "Gegevens succesvol geladen, totaal " & rs.RecordCount & " records.", vbInformation, "Gelukt"
Else
MsgBox "Ongedefinieerde fout", vbInformation, "Fout"
End If
Case 3146
MsgBox "Fout in Query", vbInformation, "Fout"
Case Else
MsgBox Err.Description, vbInformation, "Fout"
End Select
End SubVoorbeeld met VBA in bijlage:
Bekijk bijlage samenvoegen.xlsm
Laatst bewerkt:
