Code:
Public Sub Write2XLSFile(varArray() As Variant, strXLSFile As String, strXLSSheet As String, Optional boContinue As Boolean = False, Optional strXLTFile As String = "")
'2-dimensionale Matrix in das Tabellenblatt einer XLS-Datei schreiben.
'Unter Verweise... MS Excel auswählen!!'Eingangswerte:
'varArray = 2-dim Matrix mit den Daten, die in das xls-Tabellenblatt geschrieben werden sollen.
'strXLSFile = Dateiname mit kompletter Pfadangabe z.B.: "C:\temp\ExcelTest.xlsx"
'strXLSSheet = Name des Tabellenblattes
'boContinue = Wenn Datei und Tabellenblatt vorhanden: Sollen die Daten unten angefügt werden?
'strXLTFile = Name der Vorlagendatei mit kompletter Pfadangabe z.B.: "C:\temp\ExcelTestVorlage.xlt"
'Variablendefinition
Dim intI As Integer, intJ As Integer, intZ As Integer, intS As Integer 'Laufvariablen
Dim XLSOff As Boolean ' Attribut für Freigabe am Ende.
Dim WBOpen As Boolean ' Datei bereits offen?
Dim WBNew As Boolean ' Datei neu erstellen?
Dim AnzWB As Integer ' Anzahl der offnen Workbooks
Dim SheetExist As Boolean 'Tabellenblatt bereits vorhanden?
Dim SheetNew As Boolean 'Tabellenblatt neu gemacht?
Dim strXLSSheetOrg As String 'Originalname zwischenspeichern
Dim ZStart As Integer 'erste freie Zeile im XLS-Tabellenblatt
Dim XLApp As Excel.Application ' Variable für Verweis auf Microsoft Excel.
Dim XLwb As Excel.Workbook
Dim XLsheet As Excel.Worksheet
' Überprüfen, ob eine Kopie von Microsoft Excel bereits ausgeführt wird.
On Error Resume Next ' Fehlerbehandlung zurückstellen.
' GetObject-Funktionsaufruf ohne erstes Argument gibt einen Verweis auf eine Instanz der Anwendung zurück.
' Wenn die Anwendung nicht ausgeführt wird, tritt ein Fehler auf.
Set XLApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
XLSOff = True
Set XLApp = CreateObject("Excel.Application")
XLApp.Application.Visible = True
XLApp.Parent.Windows(1).Visible = True
End If
Err.Clear ' Err-Objekt im Fehlerfall löschen.
' Prüfen auf Microsoft Excel. Wenn Microsoft Excel ausgeführt wird, wird
' dies in die Tabelle ausgeführter Objekte eingetragen.
DetectExcel
' Objektvariable so festlegen, dass sie auf die gewünschte Datei verweist.
Set XLApp = GetObject(strXLSFile, "Excel.Application")
' Microsoft Excel mit zugehöriger Application-Eigenschaft einblenden.
' Fenster mit der Datei unter Verwendung der Windows-Auflistung des XLApp-Objektverweises anzeigen.
XLApp.Application.Visible = True
XLApp.Parent.Windows(1).Visible = True
'Überprüfen, ob irgendein Workbook offen ist.
' Workbooks zählen
AnzWB = XLApp.Workbooks.Count
If AnzWB <> 0 Then
'Überprüfen, ob die Datei bereits geöffnet ist.
For Each XLwb In XLApp.Workbooks
If UCase(XLwb.FullName) = UCase(strXLSFile) Then
WBOpen = True 'Datei ist offen
Exit For
End If
Next XLwb
' Erstes Workbook sichtbar machen
'XLApp.Parent.Windows(1).Visible = True
Else ' kein Workbook offen, nur Excel läuft
XLSOff = True 'Excel schließen 'optional
' XLApp.Visible = True
End If
'XLS ist jetzt offen, aktiviert
If WBOpen = False Then 'Workbook ist noch nicht offen
' Workbook öffnen.
' Datei muss vorhanden sein! Ansonsten Fehlerbehandlung
On Error Resume Next
XLApp.Workbooks.Open strXLSFile 'Datei öffnen.
Debug.Print "WB nicht offen? Err.Number= " & Err.Number
If Err.Number <> 0 Then
'Datei ist nicht vorhanden:
' -> neues WB aufmachen und speichern. Dann ist sie vorhanden.
WBNew = True
Set XLwb = XLApp.Workbooks.Add 'Workbook hinzufügen
'und unter dem gewünschten Namen speichern
XLwb.SaveAs strXLSFile
WBOpen = True
Else
Debug.Print " Datei ist schon vorhanden und wird geöffnet."
End If
Err.Clear ' Err-Objekt im Fehlerfall löschen.
Set XLwb = XLApp.ActiveWorkbook
Else 'Workbook ist bereits offen(, aber u.U. noch nicht aktiv?)
Set XLwb = XLApp.Workbook.stgrXLSFile
End If
intI = 0 'Zähler für Tabellenblattnamenserweiterung auf 0 setzen
strXLSSheetOrg = strXLSSheet 'Originalnamen zwischenspeichern
CheckSheet:
'Überprüfen, ob es das Tabellenblatt bereits gibt
For Each XLsheet In XLwb.Application.Sheets 'XLwb.Sheets
Debug.Print XLsheet.Name
If UCase(XLsheet.Name) = UCase(strXLSSheet) Then
SheetExist = True 'In der Arbeitsmappe gibt es bereits ein Tabellenblatt mit dem gewünschten Namen
Exit For
End If
Next XLsheet
'Tabellenblatt aktiv setzen, erstellen
If SheetExist = False Then
'Es gibt noch kein Tabellenblatt mit dem gewünschten Namen
Set XLsheet = XLwb.Worksheets.Add
With XLsheet
.Name = strXLSSheet 'Name des Tabellenblattes festlegen
.Move after:=XLwb.Worksheets(XLwb.Worksheets.Count) 'Tabellenblatt ans Ende schieben
.Select 'Tabellenblatt auswählen
End With
Debug.Print " Neues Tabellenblatt erstellt"
boContinue = False 'In neues Tabellenblatt schreiben, bei "A1" beginnen
Else
If boContinue = True Then 'Neue Werte in erster freier Zeile anfügen
Set XLsheet = XLwb.Worksheets(strXLSSheet)
Else 'boContinue = False
'Neuen Tabellenblattnamen generieren
intI = intI + 1
strXLSSheet = strXLSSheetOrg & intI
SheetExist = False
GoTo CheckSheet 'Prüfen, ob es den Namen schon gibt
End If
End If
'Tabellenblatt für Eingabe der Matrix aktiv setzen
XLwb.Worksheets(strXLSSheet).Select
.....
Set XLsheet = Nothing ' Verweis auf Sheet freigeben.
' Speichern der Datei
'Wenn die Datei noch nicht vorhanden war, wurde sie bereits beim Anlegen unter dem gewünschten Namen gespeichert.
'eine Unterscheidung "SaveAs / Save" ist somit nicht mehr notwendig.
'Vorhandene Datei speichern
On Error Resume Next
XLwb.Save
' Wenn diese Kopie von Microsoft Excel beim Starten des Beispiels
' nicht ausgeführt wurde, wird Excel mit der Quit-Methode des Application-Objekts beendet.
' Wenn Sie versuchen, Microsoft Excel zu beenden, blinkt die Titelleiste,
' und Sie werden in einer Meldung gefragt, ob Sie geladene Dateien speichern möchten.
If XLSOff = True Then
XLApp.Application.Quit
End If
Set XLwb = Nothing ' Verweis auf Anwendung und Tabelle freigeben.
Set XLApp = Nothing
End Sub
Foren auf CAD.de
| 
