PDA

Vollständige Version anzeigen : Export in Excel mit Autofit


ugur1981
27.09.2005, 11:56
Hi,

ich benutze Access2003 und Windows XP, und versuche seit längerem, einen Tabellen- und einen Abfrageinhalt zu Excel zu exportieren.
mit
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Abfrage4", Path, False, ""

klappt es zwar einigermaßen, ich konnte aber nicht verstellen, da die Tabelle so zu unansehlich ist, habe ich hier im Forum nachgeschaut, und mir folgenden Code zusammengereimt: allerdings kommt der Fehler:
"Objecterstellung durch ActiveX Komponente nicht möglich"

das ist mien "neuer" Code:

Private Sub toExl1_Click()
On Error GoTo Err_toExl1_Click

Dim Path As String
Path = DateiSpeichern("H:\", "Datei speichern")
MsgBox Path

'Dim name As String
Set MyExcel = GetObject(, "Excel.Application")
CreateObject ("Excel.Application")

Dim appXLS As Excel.Application
Dim wbkXLS As Excel.Workbook
Dim wksXLS As Excel.Worksheet
Dim rs As DAO.Recordset
Dim Spalte As Long
Dim Zeile As Long

'+++ Excel zuweisen
Set appXLS = New Excel.Application
Set wbkXLS = appXLS.Workbooks.Add
Set wksXLS = wbkXLS.Worksheets("Tabelle1")

'//Recordset öffnen
Set rs = DBEngine(0)(0).OpenRecordset("Abfrage4", dbOpenDynaset)

Zeile = 1

'//Mit einer Schleife wird der Recordset durchlaufen und die Daten
'//an Excel übergeben
While Not rs.EOF
For Spalte = 0 To rs.Fields.Count - 1
wksXLS.Cells(Zeile, Spalte + 1) = rs.Fields(Spalte)
Next
Zeile = Zeile + 1
rs.MoveNext
Wend

With wksXLS
.Range("A:E").AutoFit
'Rahmen aussenherum
.Range("A1:E" & Zeile).BorderAround xlcontinous, xlThin, xlColorIndexAutomatic

'Rahmen innen horizontal und vertikal
With .Range("A1:E" & (Zeile - 1)).Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

With .Range("A1:E" & Zeile).Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

'Seitenausrichtung
.PageSetup.Orientation = xlLandscape
End With

wbkXLS.SaveAs "C:\Test.xls"

wbkXLS.Close
appXLS.Quit
rs.Close
Set wksXLS = Nothing
Set wbkXLS = Nothing
Set appXLS = Nothing
Set rs = Nothing
'DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Abfrage4", Path, False, ""

Exit_toExl1_Click:
Exit Sub

Err_toExl1_Click:
MsgBox Err.Description
Resume Exit_toExl1_Click

End Sub

wäre für Hilfe echt dankbar..

lg
ugur

molnar
27.09.2005, 12:37
Set MyExcel = GetObject(, "Excel.Application")
verbindet mit einem bereits laufenden Excel und führt andernfalls zu einem Fehler.

Set MyExcel = CreateObject ("Excel.Application")
startet eine weitere Excel-Instanz.

Rufe nur CreateObject mit der korrekten Syntax auf. Das sollte funktionieren.
Außerdem solltest Du Worksheets(1) statt Worksheets("Tabelle1") benutzen, um vom Blattnamen unabhängig zu sein.

Gruß,
Reinhard

ugur1981
27.09.2005, 13:06
Ok danke :)
jetzt gibt es nur noch die Fehlermeldung, das die Range.AutoFit Anweisung nicht ausgeführt werden konnte.
die zellengröße wurde auch nicht angepasst. Ich habe auch keine Rahmen erhalten..

was mache ich falsch?
kann es damit zusammenhängen, dass ich nicht unter "C:\Test.xls"
speichere?

ugur1981
27.09.2005, 13:09
Nun stand: die Methode 'Range' für das Object '_Worksheet' konnte nicht ausgeführt werden.. ??

JörgG
27.09.2005, 13:18
Hallo,

wenn Du XL-Befehle unter Ac verwendest, hast Du im VBA-Fenster Extras - Verweise "Microsoft Excel x.x Object Library" aktiviert?

ugur1981
27.09.2005, 13:27
ja das habe ich schon gemacht ...

JörgG
27.09.2005, 13:47
Ich hab jetzt mal meine DB's durchforstet und festgestellt das ich einzelne Zellen mit Range() und Zellbereiche mit Cells(), Rows() und Columns() angesprochen habe, keine Ahnung mehr warum, probiers mal aus.

Edit: nach Deiner letzten Änderung, ist das Objekt überhaupt geöffnet .Visible = True

ugur1981
27.09.2005, 13:57
danke, aber das habe ich jetzt nicht ganz verstanden..
meinst du die Methoden ohne parameter zu benutzen?
Also nichts in die Klammer zu schreiben?

molnar
27.09.2005, 13:57
.Cells.EntireColumn.AutoFit müßte alle Spalten des Arbeitsblattes optimieren.

Reinhard

ugur1981
27.09.2005, 14:25
super!!!
ihr habt mir wirklich weitergeholfen.. ich war schon am verzweifeln..wie schaffe ich es jetzt aber, die Spaltenüberschriften mitzuliefern?
gibt es dafür ne Lösung?
vielen dank nochmal..

Großer Meister
27.09.2005, 14:34
Beitrag wieder gelöscht. (transferspreedsheet verwendest du ja nicht)
aber ist ja kein Problem, siehe unten.

molnar
27.09.2005, 14:36
Indem Du in einer ersten Schleife über die Felder des Recordsets die 1. Zeile des Tabellenblattes mit rs.Fields(Spalte).Name füllst. Die Daten folgen dann ab der 2. Zeile.

Reinhard

ugur1981
27.09.2005, 15:02
und wie mache ich das genau?
kenn mich mit rs überhauptnicht aus :(

Großer Meister
27.09.2005, 15:08
so ungefähr:
While Not rs.EOF
if zeile=1 then wksXLS.Cells(Zeile, Spalte + 1) = rsFields(Spalte).Name
else
For Spalte = 0 To rs.Fields.Count - 1
wksXLS.Cells(Zeile, Spalte + 1) = rs.Fields(Spalte)
Next
endif
Zeile = Zeile + 1
rs.MoveNext
Wend

ugur1981
27.09.2005, 15:25
super DANKE!! :D
jetzt geht es.. allerdings musste ich für die Spalten überschriften eine extra For SChleife einfügen:
While Not rs.EOF
If Zeile = 1 Then
For Spalte = 0 To rs.Fields.Count - 1
wksXLS.Cells(Zeile, Spalte + 1) = rs.Fields(Spalte).Name
Next

Else
For Spalte = 0 To rs.Fields.Count - 1
wksXLS.Cells(Zeile, Spalte + 1) = rs.Fields(Spalte)
Next
End If

Zeile = Zeile + 1
rs.MoveNext
Wend
danke nochmal...