PDA

Vollständige Version anzeigen : Exceldatei erstellen aus Datenbank mit Filter und Ersetzfunktion


der_mythos
24.10.2011, 17:49
Hi Community,

da ich ewig auf der Suche nach einer solchen Funktion war und keine gefunden habe, möchte ich die doch mit euch teilen.

Was kann die Funktion? Erstellt ein Excelfile aus der Datenbank wobei, gewissen Spalten weggelassen werden können und man nach Strings suchen + ersetzen kann.

Vielleicht brauchts ja einer :D

Das das Vorgehen absolut Ineffizient ist, ist klar. Aber funktioniert ganz gut.

Achja viele Codeteile sind aus dem Internet geklaut.



' Erstellt ein Excelfile Aus einer Datenbank.
' strSQL - SQL String
' FieldsToIgnore - Array mit Angabe der Spalten die nicht mit in die Excel sollen (Als Zahlen!!!)
' OriginalData - Zu ersetzender String
' NewData - Der neue String
Public Sub createExcel(strSQL As String, FieldsToIgnore As Variant, OriginalData As Variant, NewData As Variant)

Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim recArray As Variant
Dim recCount As Long
Dim xlApplication As excel.Application
Dim xlWorkbook As excel.Workbook
Set xlApplication = CreateObject("Excel.Application")
Set xlWorkbook = xlApplication.Workbooks.Add
Set db = CurrentDb

Set rs = db.OpenRecordset(strSQL)
rs.MoveFirst

' Copy field names to the first row of the worksheet
Dim fldCount As Integer
fldCount = rs.Fields.Count
For icol = 1 To fldCount
If Not (arrContains(FieldsToIgnore, icol)) Then
xlWorkbook.Application.Cells(1, icol).Value = rs.Fields(icol - 1).Name
xlWorkbook.Application.Cells(1, icol).Font.Bold = True
xlWorkbook.Application.Cells(1, icol).Interior.ColorIndex = 15
End If
Next


' Copy recordset to an array
recArray = rs.GetRows(1337999)
'Note: GetRows returns a 0-based array where the first
'dimension contains fields and the second dimension
'contains records. We will transpose this array so that
'the first dimension contains records, allowing the
'data to appears properly when copied to Excel

' Determine number of records

recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array

' Check the array for contents that are not valid when
' copying the array to an Excel worksheet
For icol = 0 To fldCount - 1
If Not (arrContains(FieldsToIgnore, icol + 1)) Then
For iRow = 0 To recCount - 1
' Take care of Date fields
If IsDate(recArray(icol, iRow)) Then
recArray(icol, iRow) = Format(recArray(icol, iRow))
' Take care of OLE object fields or array fields
ElseIf IsArray(recArray(icol, iRow)) Then
recArray(icol, iRow) = "Array Field"
End If
If recArray(icol, iRow) = OriginalData Then
recArray(icol, iRow) = NewData
End If
xlWorkbook.Application.Cells(2 + iRow, 1 + icol) = recArray(icol, iRow)
Next iRow 'next record
End If
Next icol 'next field


' Auto-fit the column widths and row heights
xlApplication.Selection.CurrentRegion.Columns.AutoFit
xlApplication.Selection.CurrentRegion.Rows.AutoFit

' Delete Empty rows before Last Row
Dim i As Integer
i = 0
For cols = 1 To fldCount
If arrContains(FieldsToIgnore, cols) Then
xlWorkbook.Application.Columns(cols - i).Delete
i = i + 1
End If
Next


xlApplication.Visible = True



End Sub

Private Function arrContains(Arr As Variant, Exp As Variant) As Boolean

For Y = 0 To UBound(Arr)
If Arr(Y) = Exp Then
arrContains = True
Exit Function
End If
Next Y

arrContains = False

End Function