Private Sub cmdExportExcel_Click()
On Error Resume Next
  Dim XLS As Object, WB As Object
  'Excel-Session beginnen
  Set XLS = CreateObject("Excel.Application")
  If XLS Is Nothing Then
      MsgBox "Microsoft Excel ist nicht installiert!", vbCritical 'Fehler dabei 
      ' aufgetreten?
    Else
       XLS.Dialogs(xlDialogSaveAs).Show
      'Neue Arbeitsmappe in Excel erstellen
      Set WB = XLS.Workbooks.Add
      If WB Is Nothing Then 'Fehler dabei aufgetreten?
          MsgBox "Microsoft Excel konnte keine neue Arbeitsmappe erstellen!", _
            vbCritical
      Else
      WB.Selected
      WB.Name = "Berechnung 1"
      With WB.Worksheets(1)
            .Selected
            .Name = "Allgemeine Eingaben"
            .Cells(1, 1).Selected
            .Cells(1, 1).Font.Bold = True
            .Cells(7, 1).Selected
            .Cells(7, 1).Font.Bold = True
      End With
      For intZaehler = 2 To 5
          intZaehler2 = intZaehler - 1
          WB.Worksheets(1).Cells(intZaehler, 1) = ar_BeschreibungAllgemein( _
            intZaehler2)
          WB.Worksheets(1).Cells(intZaehler, 2) = ar_ProjektBeschreibung( _
          intZaehler2)
      Next
      With WB.Worksheets(1)
            .Columns("A:A").Select
            .Columns("A:A").EntireColumn.AutoFit
            .Columns("B:B").Select
            .Columns("B:B").EntireColumn.AutoFit
            .Cells(1, 1) = "Projektbeschreibung"
            .Cells(7, 1) = "Bauherr" 
      End With
      With WB.Worksheets(2)
            .Selected
            .Name = "Ergebnis Energieaufwand"
            .Cells(1, 1).Selected
            .Cells(1, 1).Font.Bold = True
            .Cells(7, 1).Selected
            .Cells(7, 1).Font.Bold = True
            .Cells(13, 1).Selected
            .Cells(13, 1).Font.Bold = True
            .Cells(19, 1).Selected
            .Cells(19, 1).Font.Bold = True
      End With
    XLS.Dialogs(xlDialogSaveAs).Show
    End If ' If WB Is Nothing Then
    Excel beenden
    XLS.Quit
  End If ' If XLS Is Nothing Then
  'Speicher freigeben
  Set WB = Nothing
  Set XLS = Nothing
End Sub