Niquet.nl

Snelle en elegante code om vanuit Access een query (sql) te exporteren naar Excel

Exporten

Option Compare Database
Option Explicit
Dim fldCount As Integer
Dim recCount As Long

Public Function ExporterenQueryExcel(SQL As String, _
Titel As String, _
bestandsnaam As String)
'declareren variabelen
Dim db As Database
Dim rs As Recordset
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Dim ArrExp() As Variant

' Open database
Set db = CurrentDb
'Open recordset
Set rs = db.OpenRecordset(SQL)

'vullen variabelen
Dim iCol As Integer
Dim iRow As Integer
Dim rownr As Integer

'Excel openen
Set xlApp = New Excel.Application
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets.Add

'Verbergen van Excel
xlApp.Visible = False
xlApp.UserControl = False

With xlWs
.Activate
'Titel op eerste regel
With .Range("A1", "G1")
.Font.Name = "Arial"
.Merge
.Range("A1", "E1").value = Titel
.Font.Bold = True
.Font.Size = 22
End With

'Plakken veldnamen op regel 4
'Vanwege loop is het aantal velden variabel in te stellen (door bepaling SQL code)
fldCount = rs.Fields.Count
For iCol = 1 To fldCount

With xlWs.Cells(4, iCol)
.Font.Name = "Arial"
.value = rs.Fields(iCol - 1).Name
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.ThemeColor = xlThemeColorAccent5
.Interior.TintAndShade = 0.799981688894314
.Interior.PatternTintAndShade = 0
.Font.Size = 12
End With

Next iCol

If rs.RecordCount = 0 Then

recCount = 0
.Cells(5, 1).value = "Geen records gevonden!"

'MsgBox "Er zijn geen records gevonden. Pas de SQL query aan en probeer opnieuw.", vbOKOnly, "EXporteren query naar Excel"
Exit Function

Else
recCount = rs.RecordCount
.Cells(5, 1).CopyFromRecordset rs

End If

.Cells(4, 1).CurrentRegion.EntireColumn.AutoFit
.Cells(4, 1).Select

.Range("A5").Select
.Range("A5").Activate
With xlApp.ActiveWindow
.FreezePanes = False
.ScrollRow = 1
.ScrollColumn = 1
.FreezePanes = True
.ScrollRow = 5
End With

End With

rs.Close

xlApp.Visible = True
xlApp.UserControl = True

Set xlApp = Nothing
Set rs = Nothing
Set db = Nothing

End Function

Fraaie aanvulling

Nog mooier is het om de tabel na export te verfraaien met de mooie tabelstijlen van Excel.
Om dit voor elkaar te krijgen, dan moet je na het plakken van de recordset onderstaande code zetten:

Set r = .Range("a4").CurrentRegion
r.EntireColumn.AutoFit
r.Select

.ListObjects.Add(xlSrcRange, r, , xlYes).Name = "relaties"
.ListObjects("relaties").TableStyle = "TableStyleMedium8"

Dan ziet de gehele code er als volgt uit:

 


Option Compare Database
Option Explicit
Dim fldCount As Integer
Dim recCount As Long

Public Function ExporterenQueryExcel(SQL As String, _
Titel As String, _
bestandsnaam As String)
'declareren variabelen
Dim db As Database
Dim rs As Recordset
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook
Dim xlWs As Excel.Worksheet
Dim ArrExp() As Variant
Dim r As Excel.Range

' Open database
Set db = CurrentDb
'Open recordset
Set rs = db.OpenRecordset(SQL)

'vullen variabelen
Dim iCol As Integer
Dim iRow As Integer
Dim rownr As Integer

'Excel openen
Set xlApp = New Excel.Application
Set xlWb = xlApp.Workbooks.Add
Set xlWs = xlWb.Worksheets.Add

' Display Excel and give user control of Excel's lifetime
xlApp.Visible = False
xlApp.UserControl = False

With xlWs
.Activate
'Titel op eerste regel
With .Range("A1", "G1")
.Font.Name = "Arial"
.Merge
.Range("A1", "E1").value = Titel
.Font.Bold = True
.Font.Size = 22
End With

'Plakken veldnamen op regel 4
'Vanwege loop is het aantal velden variabel in te stellen (door bepaling SQL code)
fldCount = rs.Fields.Count
For iCol = 1 To fldCount

With xlWs.Cells(4, iCol)
.Font.Name = "Arial"
.value = rs.Fields(iCol - 1).Name
' .Interior.Pattern = xlSolid
' .Interior.PatternColorIndex = xlAutomatic
' .Interior.ThemeColor = xlThemeColorAccent5
' .Interior.TintAndShade = 0.799981688894314
' .Interior.PatternTintAndShade = 0
.Font.Size = 12
End With

Next iCol

If rs.RecordCount = 0 Then

recCount = 0
.Cells(5, 1).value = "Geen records gevonden!"

'MsgBox "Er zijn geen records gevonden. Pas de SQL query aan en probeer opnieuw.", vbOKOnly, "EXporteren query naar Excel"
Exit Function

Else
recCount = rs.RecordCount
.Cells(5, 1).CopyFromRecordset rs

End If

Set r = .Range("a4").CurrentRegion
r.EntireColumn.AutoFit
r.Select

.ListObjects.Add(xlSrcRange, r, , xlYes).Name = "relaties"
.ListObjects("relaties").TableStyle = "TableStyleMedium8"

'.Cells(4, 1).CurrentRegion.EntireColumn.AutoFit
'.Cells(4, 1).Select

.Range("A5").Select
.Range("A5").Activate
With xlApp.ActiveWindow
.FreezePanes = False
.ScrollRow = 1
.ScrollColumn = 1
.FreezePanes = True
.ScrollRow = 5
End With

End With

rs.Close

xlApp.Visible = True
xlApp.UserControl = True

'xlWb.SaveAs bestandsnaam

Set xlApp = Nothing
Set rs = Nothing
Set db = Nothing

End Function

Leave a Comment