Recordset Type Date
Andi
ich erstelle einer Excelübersicht. Die Daten werden auf vielen "Excel Formularen" erstellt.
Hier werden Daten des Types long, date und string verarbeitet. Die "Formulare" sind gesammelt in Ordner an verschieden Server Orten.
Um die Daten auszulesen, bediente ich mich der Methode jedes Excelfile via VBA zu öffnen und die Daten in ein array des Types variant einzulesen. Mittlerweile benötigt ein Update ca. 9 min Laufzeit!
Die 9 min sind mir zu lang und gewiss langfristig keine Killer Application.
Eine neue Methode mußte her.
Da eine Excel Datei nichts anderes als eine "Mini" Datenbank ist, dachte ich mir die Daten über eine fertige VB Datenbankschnittstelle "ADODB" zu ziehen.
Das funktioniert alles wunderbar, Update Laufzeit nur noch 1:22 min ;-)).
Aber vorhandene Excel Daten vom Type Date erhalten im Recordset field F6 den Wert "Leer".
Werte vom Typ Datum werden übertragen als "Leer". Wäre nichts da, würde der Wert "Null" angezeigt werden.
Kann man einen Recordset als variant deklarien?
Danke.
Gruß Andi
Anbei Code:
Function ADOExcel(ByRef ExcelPath As String, ByRef Tabelle As String, Optional Countrows As _
Long = 500) As Variant
Dim rs As New ADODB.Recordset
Dim arrADO() As Variant
Dim arrEXC() As Variant
Dim n, m, k, i, Max As Long
Set rs = ExcelTable(ExcelPath, Tabelle)
rs.MoveFirst
Erase arrADO
arrADO = rs.GetRows(Countrows)
arrEXC = TransposeArray(arrADO)
Erase arrADO
arrADO = arrEXC
Erase arrEXC
ReDim arrEXC(1 To UBound(arrADO) + 1, 1 To UBound(arrADO, 2) + 1)
For m = LBound(arrADO) To UBound(arrADO)
For n = LBound(arrADO, 2) To UBound(arrADO, 2)
arrEXC(m + 1, n + 1) = arrADO(m, n)
Next
Next
Erase arrADO
ReDim arrADO(1 To UBound(arrEXC) + 1, 1 To UBound(arrEXC, 2))
rs.MoveFirst
For m = LBound(arrEXC) To UBound(arrEXC) + 1
For n = LBound(arrEXC, 2) To UBound(arrEXC, 2)
If m = 1 Then
For i = 0 To rs.Fields.Count - 1
arrADO(m, i + 1) = rs.Fields(i).Name
Next
Else
arrADO(m, n) = arrEXC(m - 1, n)
End If
Next
Next
rs.Close
ADOExcel = arrADO
End Function
Function ExcelTable(ByRef ExcelPath As String, ByRef Tabelle As String) As ADODB.Recordset
Dim excelfile As New ADOX.Catalog
Dim cn As New ADODB.Connection
Dim SQL As String
Dim Con As String
SQL = "select * from [" & Tabelle & "$]"
Con = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & "Data Source=" & _
ExcelPath & ";"
Call cn.Open(Con)
'ADOX Anzahl Tabellen
Set excelfile.ActiveConnection = cn
'MsgBox excelFile.Tables.Count
AnzahlTab = 0
For i = 0 To excelfile.Tables.Count - 1
If Right(excelfile.Tables(i).Name, 1) = "$" Then
AnzahlTab = AnzahlTab + 1
End If
Next
ThisWorkbook.Sheets("Optional").Cells(1, 2) = AnzahlTab
Set ExcelTable = New ADODB.Recordset
ExcelTable.Open SQL, Con, adOpenKeyset, adLockOptimistic
cn.Close
End Function
Function TransposeArray(v As Variant) As Variant
Dim X, Y, Xupper, Yupper As Long
Dim tempArray() As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next
Next
TransposeArray = tempArray
End Function