Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Export nach Excel mit allem Drum und Dran
zurück: ODBC Anbindung von SQL Server und MySQL Server Tabellen weiter: Listenfelder gruppieren Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Tutorial Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen

Ist EXCEL ein guter Partner für ACCESS?
ja
36%
 36%  [ 45 ]
nein
7%
 7%  [ 9 ]
ja, zur Weitergabe von Ergebnissen
34%
 34%  [ 42 ]
ja, zur Überprüfung von Ergebnissen
1%
 1%  [ 2 ]
ja, weil (ich hab dir eine eMail geschickt)
0%
 0%  [ 0 ]
wenn ich das nur wüßte
19%
 19%  [ 24 ]
Stimmen insgesamt : 122

Autor Nachricht
Robsl
Unmögliches wollen, um Mögliches zu erreichen


Verfasst am:
24. Feb 2004, 16:54
Rufname:
Wohnort: München

Export nach Excel mit allem Drum und Dran - Export nach Excel mit allem Drum und Dran

Nach oben
       

Hallo Gemeinde,

Tabelleninhalte nach Excel zu exportieren, ist eine relativ aufwändige Angelegenheit. Ich hatte jetzt in der Faschings- bzw. Karnevals- oder Fasenachtzeit endlich mal Zeit, mich mit diesem Problem auseinanderzusetzen. Ich glaube, der Code ist so allgemein geworden, dass man ihn veröffentlichen kann.
Code:
' Menue: Extras -> Verweise:
' Microsoft Excel x.xx Object Library muss aktiv sein!
Option Compare Database
Option Explicit

Public Function ExportExcel(objRS As Recordset, ByVal XLName As String, _
                            Optional bolFieldNames As Boolean)
On Error GoTo mkrExportExcel_Err
    Dim intXLOpen As Integer
    Dim objExcel As Excel.Application
    Dim objExcelSheet As Excel.Worksheet
    Dim intExcelCalcMode As Integer
    Dim strErgString As String
    Dim strZusFass As String
    Dim strSuchFeld As String
    Dim AnzVar As Integer
    Dim SumVar As Currency
    Dim z As Integer
    Dim i As Integer

    Set objExcel = New Excel.Application
    ' Sichtbar machen und Tastatur, sowie Mauseingaben
    ' blockieren
    objExcel.Visible = True
    objExcel.Interactive = False
    ' Tabellenblatt 1 mit den Auswertungsparametern erzeugen
    objExcel.Workbooks.Add
    ' Aktives Blatt setzen
    ' Erstes Blatt benennen
    Set objExcelSheet = objExcel.ActiveWorkbook.Sheets(1)
    objExcel.ActiveWorkbook.Sheets(1).Name = "Ergebnis"
    ' Den alten Berechnungsmodus speichern
    ' und temporär auf manuell setzen
    intExcelCalcMode = objExcel.Calculation
    objExcel.Calculation = xlCalculationManual
    '  die Anzeigeaktualisierung unterdrücken
    objExcel.ScreenUpdating = False
    ' Eindeutige Kennzeichnung der Excel-Tabelle durch Kopf- und Fusszeilen
    ' Linker Fußzeilenbereich
    strErgString = "Ausw.Lauf OMS (Ende): " & _
                   Format(DLookup("AuswVom", "tabAuswertungen", _
                                  "AuswVom = " & convDat & _
                             " AND AuswUm = " & convUhr), "dd.mm.yyyy") & _
                   " - " & _
                   Format(DLookup("AuswUm", "tabAuswertungen", _
                                  "AuswVom = " & convDat & _
                             " AND AuswUm = " & convUhr), "Short Time") & _
                   " Uhr" & Chr(13) & "Ausw.Zeitraum: " & _
                   DLookup("AuswVomBis", "tabAuswertungen", _
                           "AuswVom = " & convDat & _
                      " AND AuswUm = " & convUhr) & Chr(13)
    ' Ausgewählte Parameter aus Auswertungsformular
    Select Case intAuswNr
      Case 0:
        strErgString = strErgString & "PLZ-Bereiche/Leistungsarten: "
        strErgString = strErgString & "Alle/Alle"
      Case 1:
        strErgString = strErgString & "Ausgew. PLZ-Bereich: "
        strErgString = strErgString & strPLZBer & _
                       " (" & DLookup("PLZBerName", "tabPLZBereiche", _
                                      "PLZBerNr = " & strPLZBer) & ")"
      Case 2:
        strErgString = strErgString & "Ausgewählte Leistungsart: "
        strErgString = strErgString & _
                       strLeiArt & " (" & _
                       DLookup("[Leistungsart, Klartext]", _
                               "tabLeistungsArten", _
                               "Leistungsart = '" & strLeiArt & _
                        "' And [Leistungsart (wahlfrei)] = '000'") & ")"
      Case 10:
        strErgString = strErgString & _
                       "Ausgew. PLZ-Bereich/Zuordnung Leistungsart: "
        strErgString = strErgString & "Alle/" & strZuordnung
      Case 11:
        strErgString = strErgString & _
                       "Ausgew. PLZ-Bereich/Zuordung Leistungsart: "
        strErgString = strErgString & strPLZBer & "=" & _
                       DLookup("PLZBerName", "tabPLZBereiche", _
                               "PLZBerNr = " & strPLZBer) & "/" & strZuordnung
    End Select
    ' Seitenformat festlegen
    objExcelSheet.PageSetup.Orientation = xlLandscape
    ' Beschreiben
    objExcelSheet.PageSetup.LeftFooter = strErgString
    ' Rechter Fusszellenbereich
    objExcelSheet.PageSetup.RightFooter = "Seite &P von &N"
    ' Linker Kopfzeilenbereich
    objExcelSheet.PageSetup.LeftHeader = "&B<Firma>&B" & Chr(13) & _
                                         "Controlling PKS"
    ' Mittlerer Kopfzeilenbereich
    objExcelSheet.PageSetup.CenterHeader = "&B<Anwendungsname>&B" & _
                                           Chr(13) & "Auswertungsergebnis"
    ' Rechter Kopfzeilenbereich
    ' Benutzer- und Computernamen auslesen
    ElectUserComputer
    objExcelSheet.PageSetup.RightHeader = UserName & Chr(13) & _
                                          "Ausgabe am " & _
                                          Format(Date, "dd.mm.yyyy") & _
                                          Chr(13) & _
                                          "Auswertung Nr. " & intAuswNr
    objExcelSheet.DisplayPageBreaks = False
    objExcelSheet.PrintPreview
    ' Sind Feldnamen gewünscht, diese in die erste Zeile schreiben
    If bolFieldNames = True Then
        For i = 0 To objRS.Fields.Count - 1
            objExcelSheet.Cells(1, i + 1).Value = objRS.Fields(i).Name
        Next
        ' und fett formatieren
        objExcelSheet.Range(objExcelSheet.Cells(1, 1), _
        objExcelSheet.Cells(1, i)).Font.Bold = True
        ' die Anzeigeaktualisierung unterdrücken
        objExcel.ScreenUpdating = False
        ' Das Recordset einlesen
        objExcelSheet.Range("A2").CopyFromRecordset objRS
      Else
        ' die Anzeigeaktualisierung unterdrücken
        objExcel.ScreenUpdating = False
        ' Das Recordset einlesen
        objExcelSheet.Range("A1").CopyFromRecordset objRS
    End If
    ' Formatieren der Zellen und Berechnungen
    With objExcel
        .Range("B:B").NumberFormat = "#,###"
        .Range("C:D").NumberFormat = "#,##0.00 €"
        .Range("E:E").NumberFormat = "#,###"
        .Range("F:H").NumberFormat = "#,##0.00 €"
        .Range("I:J").NumberFormat = "##0.000%"
        .Range("K:L").NumberFormat = "[=0]""Nein"";[=1]""Ja"";Standard"
        .Range("K1") = "K_ü_Ø"
        .Range("L1") = "A_ü_V"
        ' Tabellenname für Werte und Summenzeile festlegen
        If intAuswNr = 10 Or intAuswNr = 0 Or intAuswNr = 2 Then
            strZusFass = "tabZusFassungEndg"
            strSuchFeld = "[PLZ-Bereich]"
            z = 12
          ElseIf intAuswNr = 1 Or intAuswNr = 11 Then
            strZusFass = "tabZusFassungEndg1"
            strSuchFeld = "[LeiArt]"
            ' Datensätze zählen
            z = DCount("[LeiArt]", "tabZusFassungEndg1") + 2
          Else
            Exit Function
        End If
        ' vorhandene PLZ-Bereiche/L-Arten
        AnzVar = DCount(strSuchFeld, strZusFass)
        .Range("A" & z) = AnzVar
        ' Summe Fallzahl
        SumVar = DSum("[Fallzahl AWZ]", strZusFass)
        .Range("B" & z) = SumVar
        ' Summe Betrag AuswZR
        SumVar = DSum("[Gesamtbetrag AWZ]", strZusFass)
        .Range("C" & z) = SumVar
        ' Berechnung Kosten je Fall insgesamt
        ' Null bei Fallzahl abfangen
        If DSum("[Fallzahl AWZ]", strZusFass) = 0 Then
            SumVar = 0
          Else
            SumVar = DSum("[Gesamtbetrag AWZ]", strZusFass) / _
                DSum("[Fallzahl AWZ]", strZusFass)
        End If
        ' wie oben nur für Vorjahr
        .Range("D" & z) = SumVar
        SumVar = DSum("[Fallzahl Vorjahr]", strZusFass) ' Fallzahl
        .Range("E" & z) = SumVar
        SumVar = DSum("[Gesamtbetrag Vorjahr]", strZusFass)     ' Betragssumme
        .Range("F" & z) = SumVar
        If DSum("[Fallzahl Vorjahr]", strZusFass) = 0 Then
            SumVar = 0
          Else
            SumVar = DSum("[Gesamtbetrag Vorjahr]", strZusFass) / _
                     DSum("[Fallzahl Vorjahr]", strZusFass)   ' Kosten je Fall
        End If
        .Range("G" & z) = SumVar
        ' Veränderung AWZ ggüber Vorjahr
        If DSum("[Fallzahl AWZ]", strZusFass) + _
           DSum("[Fallzahl Vorjahr]", strZusFass) = 0 Then
            SumVar = 0
          Else
            If DSum("[Fallzahl AWZ]", strZusFass) = 0 And _
               DSum("[Fallzahl Vorjahr]", strZusFass) > 0 Then
                SumVar = 0 - DSum("[Fallzahl Vorjahr]", strZusFass)
              ElseIf DSum("[Fallzahl Vorjahr]", strZusFass) = 0 And _
                     DSum("[Fallzahl AWZ]", strZusFass) > 0 Then
                SumVar = DSum("[Gesamtbetrag AWZ]", strZusFass) / _
                         DSum("[Fallzahl AWZ]", strZusFass)
              Else
                SumVar = (DSum("[Gesamtbetrag AWZ]", strZusFass) / _
                          DSum("[Fallzahl AWZ]", strZusFass)) - _
                         (DSum("[Gesamtbetrag Vorjahr]", strZusFass) / _
                          DSum("[Fallzahl Vorjahr]", strZusFass))
            End If
        End If
        .Range("H" & z) = SumVar
        ' Summe Ausgabenanteil (=100%) für Kontrollzwecke
        AnzVar = DSum("[Ausgabenanteil]", strZusFass)
        .Range("I" & z) = AnzVar
        .Range("I" & z).NumberFormat = "000%"
        ' Summe Versichertenanteil (=100%, nur für ZusFassung nach PLZ-Berei.)
        ' f. Kontrollzwecke
        If Len(strZusFass) = 17 Then
            AnzVar = DSum("[Versichertenanteil]", strZusFass)
            .Range("J" & z) = AnzVar
            .Range("J" & z).NumberFormat = "000%"
        End If
        ' Die letzte Datenzeile wird unterstrichen ...
        With objExcelSheet.Range("A" & z - 1 & ":L" & z - 1)
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).Weight = xlThin
        End With
        ' ... und fett gedruckt
        .Range("A" & z & ":L" & z).Font.Bold = True
        ' Seitenformatierungen (Gitternetzlinien, alles auf 1 Blatt
        ' linker und rechter Seitenrand [sonst passt's nicht])
        objExcelSheet.PageSetup.PrintGridlines = True
        objExcelSheet.PageSetup.Zoom = 75
        objExcelSheet.PageSetup.LeftMargin = objExcel.CentimetersToPoints(1.5)
        objExcelSheet.PageSetup.RightMargin = objExcel.CentimetersToPoints(1)
        ' Gehört zu nächstem Befehl!
        .Range("A2").Select
    End With
    ' Überschrift fixieren
    objExcel.ActiveWindow.FreezePanes = True
    ' Spaltenbreite optimal einstellen
    objExcel.Range("A:K").Columns.AutoFit
    ' Schluss-Stellung
    objExcel.Range("A2").Select
    ' die Anzeigeaktualisierung einschalten
    objExcel.ScreenUpdating = True
    ' Den alten Berechnungsmodus reaktivieren
    objExcel.Calculation = intExcelCalcMode
    ' Tastatur- und Mauseingaben wieder zulassen
    objExcel.Interactive = True
    ' Objektreferenzen zerstören
    Set objExcelSheet = Nothing
    Set objExcel = Nothing
mkrExportExcel_Exit:
    Exit Function
mkrExportExcel_Err:
    MsgBox Error$
    Resume mkrExportExcel_Exit
End Function

Es ist glaube ich alles drin, von der Zellenansteuerung über Kopf- und Fußzeile bis hin zur Formatierung. Also nicht wegen der vielen Codezeilen aufgeben. Ein bißchen was müsst ihr natürlich anpassen.

Die Grundlagen für diese Funktion habe ich übrigens aus dem Buch "DAS ACCESS-VBA Codebook" Addison-Wesley, ISBN 3-8273-1953-6, das ich sehr empfehlen kann.

Viel Spaß und

_________________
Grüße, Robsl (Office 2003)
Einen guten Programmierer erkennt man am Datendrang
FabiRq
VBA-Programmer (Excel/Access)


Verfasst am:
09. März 2004, 13:58
Rufname:


Verbesserungsvorschlag - Verbesserungsvorschlag

Nach oben
       

Hallo Rob.

mir ist aufgefallen, dass Du Excel per Variablen steuerst. Das kann zu Problemen beim Beenden (Application.quit) führen: Evtl. verbleibt ein hartnäckiger Prozess im Hintergrund aktiv und führt dazu, dass Excel sich nicht mehr starten lässt.

Besser als:
Code:
    Dim objExcel As Excel.Application

wäre:
Code:
    Dim objExcel As Object
    Set objExcel...

'... ich habe dazu auch einen Beitrag mit ausführlichem Code-Beispiel in die FAQ-Vorschlagsliste eingetragen (Access Programmierung).

Viele Grüsse

Fabian
Robsl
Unmögliches wollen, um Mögliches zu erreichen


Verfasst am:
09. März 2004, 15:29
Rufname:
Wohnort: München

Probleme beim Beenden von "ferngesteuertem" Excel - Probleme beim Beenden von "ferngesteuertem" Excel

Nach oben
       

Hallo Fabian,

du hast du zweifellos recht.

Deshalb für alle, denen es so geht die FAQ von Fabian:
Excel Fernsteuern --> Excel beendet nicht korrekt
Ich hab deshalb keine Probleme damit, weil die Datenbank geteilt wurde und im Netzwerk arbeitet. Nach dem Beenden des Zugriffs über eine Emulation werden alle Einstellungen zurückgesetzt. Da bleibt keine Anwendung mehr trocken - ääh offen oder im Speicher.

_________________
Grüße, Robsl (Office 2003)
Einen guten Programmierer erkennt man am Datendrang
Willi Wipp
Moderator


Verfasst am:
27. Jul 2004, 09:58
Rufname:
Wohnort: Raum Wiesbaden

Re: Export nach Excel mit allem Drum und Dran - Re: Export nach Excel mit allem Drum und Dran

Nach oben
       

Nachfragen zum Thema bitte hier Export nach Excel mit allem Drum und Dran {Nachgefragt} stellen.
rita2008
Im Profil kannst Du frei den Rang ändern


Verfasst am:
21. Jul 2009, 17:16
Rufname:
Wohnort: Berlin


Funktionsabschluss - Funktionsabschluss

Nach oben
       

Ich habe mir angewöhnt, Abschlussarbeiten hinter die Exit-Marke zu setzen. Dann wird das Programm auch bei Fehlern sauber beendet. Das Ende der Funktion würde dann so aussehen:
Code:
    ' Überschrift fixieren
    objExcel.ActiveWindow.FreezePanes = True
    ' Spaltenbreite optimal einstellen
    objExcel.Range("A:K").Columns.AutoFit
    ' Schluss-Stellung
    objExcel.Range("A2").Select
mkrExportExcel_Exit:
  ' die Anzeigeaktualisierung einschalten
    objExcel.ScreenUpdating = True
    ' Den alten Berechnungsmodus reaktivieren
    objExcel.Calculation = intExcelCalcMode
    ' Tastatur- und Mauseingaben wieder zulassen
    objExcel.Interactive = True
    ' Objektreferenzen zerstören
    Set objExcelSheet = Nothing
    Set objExcel = Nothing
    Exit Function
mkrExportExcel_Err:
    MsgBox Error$
    Resume mkrExportExcel_Exit

_________________
mfg Rita

Antworten bitte hier im Forum, nicht als private Nachricht. Danke
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Diese Seite Freunden empfehlen

Seite 1 von 1
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Access Tabellen & Abfragen: Tabellen in andere DB export. VBA ink. Beziehungsstruktur 13 theolivert 703 15. Nov 2011, 15:30
Gast Tabellen in andere DB export. VBA ink. Beziehungsstruktur
Keine neuen Beiträge Access Tabellen & Abfragen: Spaltenüberschriften werden bei Export nicht übertragen 2 ironpete 185 17. Jun 2011, 12:08
Gast Spaltenüberschriften werden bei Export nicht übertragen
Keine neuen Beiträge Access Tabellen & Abfragen: Export von Abfrage in Textdatei - Zahlen falsch gerundet 4 KarlKlammer 481 14. Feb 2011, 16:59
KarlKlammer Export von Abfrage in Textdatei - Zahlen falsch gerundet
Keine neuen Beiträge Access Tabellen & Abfragen: Export und Abfrage 3 exceler1 199 20. Okt 2010, 23:20
KlausMz Export und Abfrage
Keine neuen Beiträge Access Tabellen & Abfragen: Ich verzweifel dran... 0 Kinetik 191 28. Sep 2009, 19:03
Kinetik Ich verzweifel dran...
Keine neuen Beiträge Access Tabellen & Abfragen: Zeilenumbruch bei Export in TXT 5 Frank_online 2034 28. Jun 2009, 12:01
steffen0815 Zeilenumbruch bei Export in TXT
Keine neuen Beiträge Access Tabellen & Abfragen: Datum ändert sich beim Export von Access in Excel 14 Frenchie 2027 20. März 2009, 13:24
Gast Datum ändert sich beim Export von Access in Excel
Keine neuen Beiträge Access Tabellen & Abfragen: Abfrageprobleme (Zeitraum ab jetzt), Export nach Excel 0 Waldi_NW 404 20. März 2009, 11:33
Waldi_NW Abfrageprobleme (Zeitraum ab jetzt), Export nach Excel
Keine neuen Beiträge Access Tabellen & Abfragen: Export eines großen datensatzes 1 q3stanky 390 04. Feb 2009, 00:15
trekking Export eines großen datensatzes
Keine neuen Beiträge Access Tabellen & Abfragen: Access Export in csv Problem mit NULL Werten in DB 3 pali99 1414 23. Jan 2009, 09:51
Gast Access Export in csv Problem mit NULL Werten in DB
Keine neuen Beiträge Access Tabellen & Abfragen: Export einer Tabelle mit falschen Nachkommastellen 1 andreas k 483 12. Jan 2009, 14:42
Gast Export einer Tabelle mit falschen Nachkommastellen
Keine neuen Beiträge Access Tabellen & Abfragen: access export Pivotabelle nach Excel mit Jahr,Monat,tag 0 BenjiFrank2 1083 03. März 2008, 03:29
BenjiFrank2 access export Pivotabelle nach Excel mit Jahr,Monat,tag
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: HTML CSS