Werte in ein Excel-Objekt übertragen Mit dieser Funktion wird das Excel_Applikations_Objekt über LateBinding erzeugt und mit Werten gefüllt.
Autor:   Norbert Grimm	Bewertung:     [ Jetzt bewerten ]	Views:  13.197
ohne Homepage	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 22 Bewertung insgesamt: sehr gut Durchschnittliche Bewertung: 4.5 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Mit dieser Funktion wird das Excel_Applikations_Objekt über ein "spätes Binden" (late binding) erzeugt und mit optionalen Parametern gefüllt. Der Parameter vWert ist ein 2-dimensionales Array [vWert(x,y)], wobei y dynamisch sein kann. Die vPSxxxxx-Parameter könnte man auch als ein optionales varArray übergeben.

Die Funktion wird von mir in dieser Form (oder spez.abgewandelt) für das Übertragen von Werten aus verschiedenen Quellen der Datenbank (DatenDateien, FlexGrid, usw.) oft eingesetzt.

' Parameter: XL
'  1 = Direktes Einlesen ohne Wert-Formatierung in Excel
' 10 = Einlesen mit Wert-Formatierung anhand Datentyp
'      (Numeric / Date / Text)
'
' vWert:  2-dimensionales Array, wobei die 2. Dimension die
'         Anzahl der Spalten bestimmt
'
' vPS...: optionale Parameter für Fußzeile, Kopfzeile und Titel
'
' Rückgabewert:    0 = ok
'               <> 0 = Fehler (Err-Eigenschaft)
' -------------------------------------------------------------
Public Function CreateExcel(ByVal XL As Long, vWert As Variant, _
  Optional vTitel As Variant, _
  Optional vPSLHeader As Variant, _
  Optional vPSCHeader As Variant, _
  Optional vPSRHeader As Variant, _
  Optional vPSLFooter As Variant, _
  Optional vPSCFooter As Variant, _
  Optional vPSRFooter As Variant) As Long
 
  On Error GoTo Err_CreateExcel
 
  Dim i       As Long
  Dim j       As Long
  Dim u       As Long
  Dim LB1     As Long
  Dim UB1     As Long
  Dim LB2     As Long
  Dim UB2     As Long
  Dim s       As Long
  Dim Ret     As Long    ' Variable : Rückgabe
  Dim z       As Long
  Dim Zoom    As Long
  Dim N       As Double
  Dim xlApp   As Object  ' xlApp      As Excel.Application
  Dim xlBook  As Object  ' xlBook     As Excel.Workbook
  Dim xlSheet As Object  ' xlSheet    As Excel.Worksheet
  Dim SheetNr As Integer
 
  LB1 = LBound(vWert)   ' 2-dimensionales Array : vWert(x,y)
  UB1 = UBound(vWert)
  LB2 = LBound(vWert, 2)
  UB2 = UBound(vWert, 2)
 
  ' späte Bindung (Late-Binding)
  Set xlApp = CreateObject("Excel.Application")
  With xlApp
    SheetNr = .SheetsInNewWorkbook  ' Anzahl Tabellen merken
    .SheetsInNewWorkbook = 1        ' 1.Tabelle zuweiesen
 
    Set xlBook = .Workbooks.Add
    Set xlSheet = .Worksheets(1)
 
    With xlSheet
      .Cells.Borders.LineStyle = 1  ' xlContinuous
      .PageSetup.Orientation = 2
 
      ' -----------------------------
      ' optionale Argumente auswerten
      ' -----------------------------
 
      ' Fußzeile links
      If Not IsMissing(vPSLFooter) Then
        .PageSetup.LeftFooter = vPSLFooter
      Else
        .PageSetup.LeftFooter = Format(Now, "dddd, dd.mm.yyyy hh:mm")
      End If
 
      ' Fußzeile rechts
      If Not IsMissing(vPSRFooter) Then
        .PageSetup.RightFooter = vPSRFooter
      End If
 
      ' Fußzeile mitte
      If Not IsMissing(vPSCFooter) Then
        .PageSetup.CenterFooter = vPSCFooter
      Else
        .PageSetup.CenterFooter = "Quelle: Datenbank " & _
          Chr$(169) & " EXTRAPPS"
      End If
 
      ' Kopfzeile rechts
      If Not IsMissing(vPSRHeader) Then
        .PageSetup.RightHeader = vPSRHeader
      Else
        .PageSetup.RightHeader = "Schwabe Extracta"
      End If
 
      ' Titelzeile
      If Not IsMissing(vTitel) Then
        .PageSetup.LeftHeader = vTitel
      End If
 
      ' je nach Spaltenanzahl, Zoomfaktor einstellen
      s = UB2 - LB2 + 1
      Select Case s
        Case 11
          Zoom = 90
        Case Is > 11
          Zoom = 80
        Case Else
          Zoom = 100
      End Select
 
      If Zoom Then
        ' Breite anpassen
        .PageSetup.Zoom = Zoom
      End If
    End With
 
    ' Werte aus dem Variantarray als Text übertragen
    ' oder ggf. Datentyp abfragen und entsprechend
    ' formatiert übertragen
    Select Case XL
      ' direkt einlesen (als Text übertragen)
      Case 1
        For i = LB1 To UB1
          z = z + 1
          j = 0
          For u = LB2 To UB2
            j = j + 1
            With xlSheet
              .Cells(z, j).Font.Size = 9
              .Cells(z, j).Value = vWert(i, u)
            End With
          Next u
        Next i
 
      ' Datentyp abfragen und Werte formatiert übertragen
      Case 10
        For i = LB1 To UB1
          z = z + 1
          j = 0
          For u = LB2 To UB2
            j = j + 1
            If IsDate(vWert(i, u)) Then
              ' Datum
              With xlSheet
                .Cells(z, j).Font.Size = 9
                .Cells(z, j).Value = Format(vWert(i, u), "dd.mm.yyyy")
              End With
            ElseIf IsNumeric(vWert(i, u)) Then
              ' numerisch
              N = CDbl(vWert(i, u))
              With xlSheet
                .Cells(z, j).Font.Size = 9
                .Cells(z, j).Value = N  'V
              End With
            Else
              ' Text
              With xlSheet
                .Cells(z, j).Font.Size = 9
                .Cells(z, j).Value = vWert(i, u)
              End With
            End If
          Next u
        Next i
    End Select
 
    .Visible = True
 
    ' Anzahlen Tabellen wiederherstellen
    .SheetsInNewWorkbook = SheetNr
  End With
 
 
Exit_CreateExcel:
  ' Ret  = 0 : okay
  '     <> 0 : Fehler in Ausführung
  CreateExcel = Ret
  Exit Function
 
Err_CreateExcel:
  Ret = Err
  MsgBox Err & vbCr & Err.Description, , "CreateExcel"
  Resume Exit_CreateExcel
End Function

Beispiel:
Die Daten, die nach Excel übertragen werden sollen, befinden sich in einem mehrspaltigen ListView-Control.

' Werte vom ListView in ein Variant-Array übertragen
 
Dim nCols As Long
Dim nRows As Long
Dim vData() As Variant
Dim i As Long
Dim u As Long
Dim nResult As Long
 
With ListView1
  ' Anzahl Zeilen und Spalten für die korrekte 
  ' Dimension des Variant-Arrays ermitteln
  nCols = .ColumnHeaders.Count
  nRows = .ListItems.Count
 
  ' Array dimensionieren
  ReDim vData(nRows - 1, nCols - 1)
 
  ' alle Zeilen durchlaufen
  For i = 1 To nRows
    With .ListItems(i)
      ' Inhalt der 1. Spalte einlesen
      vData(i - 1, 0) = .Text
 
      ' jetzt alle weiteren Spalten einlesen
      For u = 1 To nCols - 1
        vData(i - 1, u) = .SubItems(u)
      Next u
    End With
  Next i
End With
 
' Daten formatiert an Excel übergeben
nResult = CreateExcel(10, vData, "vb@rchiv Tipps & Tricks")
If nResult <> 0 Then
  MsgBox "Es trat ein Fehler auf:" & vbCrLf & _
    "Fehler " & CStr(nResult), vbExclamation
End If