AW: werte in bestimmte zellen exportieren
15.11.2005 13:17:10
jens
guck mal, sollte funktionieren, ist ein auszug aus einer db-anwendung von mir. du muss den code in access implementieren und unter verweise MS-Excel einbinden.
Good luck.
Function ExcelschreibenSoko()
Dim ExcelApplikation As Excel.Application
Dim xlsWks As Excel.Worksheet
Master = "tblSoKo" 'hier wird der Tabellenname angegeben
Set db = CurrentDb
Set fs = CreateObject("Scripting.FileSystemObject")
toolvorlage = "e:\test\test.xls "
On Error GoTo errorhandler
Set ExcelApplikation = GetObject(, "Excel.Application") 'ist Excel aktiv ? wenn nicht dann zu Laufzeitfehler springen'
Err.Clear
On Error GoTo errorhandler
If ExcelApplikation Is Nothing Then
Set ExcelApplikation = CreateObject("Excel.Application")
End If
Abfrage = "SELECT * FROM " & Master & ";"
Set rs = db.OpenRecordset(Abfrage)
Set Kundentabelle = ExcelApplikation.Workbooks.Open(toolvorlage)
Set xlsWks = Kundentabelle.Worksheets("Tabelle1")
erg = SchreibeZelle(xlsWks, rs![Bereich], 7, 9, 11, False)
Set xlsWks = Nothing
Set Kundentabelle = Nothing
Set ExcelApplikation = Nothing
Set rs = Nothing
Set xlsWks = Nothing
Set Kundentabelle = Nothing
Set ExcelApplikation = Nothing
MsgBox ("Ende am " & Date & " um " & Time())
Exit Function
errorhandler:
erg = MsgBox("Fehler (" & Err.Number & "): " & Err.Description, vbCritical, "Fehler aufgetreten")
End Function
Function SchreibeZelle(ByVal Tabelle As Object, ByVal wert As String, ByVal Zeile As Integer, ByVal Spaltevon As Integer, ByVal Spaltebis As Integer, ByVal Padd As Boolean) As String
maxlen = Spaltebis - Spaltevon + 1
If Len(wert) > maxlen Then wert = Left(wert, maxlen)
If Len(wert) < maxlen And Padd = True Then wert = String(maxlen - Len(wert), "0") & wert
For I = 1 To Len(wert)
Tabelle.Cells(Zeile, Spaltevon - 1 + I) = Mid(wert, I, 1)
Next I
SchreibeZelle = "OK"
End Function