21.08.2012

VB.NET Exceldatei öffnen - schreiben - als PDF speichern

Frage: Ich arbeite mit VB im Visual Studio und benötige einen Code, der eine bestimmte Exceldatei öffnet, in ein bestimmtes Tabellenblatt etwas reinschreibt und dieses Tabellenblatt als PDF speichert. Wie geht das?

Folgender Code ist NICHT für VBA, sondern für .NET und Excel >= 2007.

Option Explicit On
Option Infer On
Public Class Form1
    Private Sub Button1_Click(ByVal sender As System.Object, _
        ByVal e As System.EventArgs) Handles Button1.Click
        Dim objExcel As Object = Nothing
        Dim objBook As Object = Nothing
        Dim objSheet As Object = Nothing
        Try
            objExcel = GetObject(, "Excel.Application")
        Catch ex As Exception
            Try
                objExcel = CreateObject("Excel.Application")
            Catch ex1 As Exception
                MsgBox("Applikation nicht installiert!", _
                    MsgBoxStyle.Critical, "Error")
            End Try
        End Try
        'objExcel.Visible = True ' zu Testzwecken
        objBook = objExcel.Workbooks.Open("C:\Temp\Book1.xls")
        objSheet = objBook.Worksheets("Tabelle1")
        objSheet.Range("B12").Value = "Test"
        objSheet.ExportAsFixedFormat(0, "C:\Temp\" & objSheet.Name)
        objBook.Close (True)
        objExcel.Quit()
        objSheet = Nothing
        objBook = Nothing
        objExcel = Nothing
        GC.Collect()
        GC.WaitForFullGCComplete()
    End Sub

Von Wordtabelle eine Zelle nach Excel

Frage: Es sind mehrere Worddateien (ca. 130 Tendenz steigend) in einem Ordner vorhanden. Jede Worddatei ist gleich aufgebaut und beinhaltet eine Tabelle. Ich möchte nun von jeder Worddatei eine bestimmte Zelle dieser Tabellen nach Excel transferieren (untereinander aufgelistet). Problem ist noch, dass in den Zellen sogenannte "Zellenende Markierung" sind - die müssen natürlich weg. Wie geht das?

Zellenende Markierung: http://support.microsoft.com/kb/901125/de
Option Explicit
Dim blnTMP As Boolean
Public Sub Test()
    Dim objDocument As Object
    Dim strDatei As String
    Dim strPfad As String
    Dim objApp As Object
    On Error GoTo Fin
    ' Pfad anpassen
    strPfad = "C:\Temp\"
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        Columns(1).Clear
        strDatei = Dir$(strPfad & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            Set objDocument = objApp.Documents.Open _
                (strPfad & strDatei)
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(1).Cell(4, 2).Range, _
                Chr(13) & Chr(7), "")
            objDocument.Close False
            strDatei = Dir$()
        Loop
    Else
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

UserForm angeklickte CheckBoxen zählen

Frage: In einer UserForm habe ich viele CheckBoxen. Wie kann ich entweder über den Typ oder über eine Zählvariable alle angeklickten CheckBoxen zählen?

Option Explicit
Private Sub CommandButton1_Click()
    Dim objCheckBox As Object
    Dim intTMP As Integer
    For Each objCheckBox In Me.Controls
        If TypeName(objCheckBox) = "CheckBox" Then
            If objCheckBox.Value = True Then
                intTMP = intTMP + 1
            End If
        End If
    Next objCheckBox
    MsgBox intTMP & " CheckBox(en) angehakt."
End Sub
Option Explicit
Private Sub CommandButton2_Click()
    Dim intCount As Integer
    Dim intTMP As Integer
    For intCount = 1 To 3
        If Me.Controls("CheckBox" & intCount).Value = True Then
            intTMP = intTMP + 1
        End If
    Next intCount
    MsgBox intTMP & " CheckBox(en) angehakt."
End Sub

Termine von Excel nach Outlook

Frage: Es sollen Termine von Excel nach Outlook übergeben werden. Das Datum steht in Spalte A ab Zeile 1 und der Betreff (Subject) in Spalte B ab Zeile 1. Ist der Termin schon vorhanden soll nichts passieren. Wie geht das?

Option Explicit
Sub Excel_Control_Termin_nach_Outlook()
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objTermin As Object
    Dim lngRow As Long
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Tabelle1") ' Anpassen!!!
    Set objOutApp = CreateObject("Outlook.Application")
    '9 = olFolderCalendar
    Set objFolder = objOutApp.GetNamespace("MAPI").GetDefaultFolder(9)
    For lngRow = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        If Not fncPointExist(objFolder, wksSheet.Cells(lngRow, 2).Value) Then
            Set objTermin = objOutApp.CreateItem(1)
            With objTermin
                .Start = Format(wksSheet.Cells(lngRow, 1).Value _
                    + 1, "dd.mm.yyyy") & " 08:00"
                .Subject = wksSheet.Cells(lngRow, 2).Value
                .Body = "Das macht Spass!"
                .Location = "tbd"
                .Duration = "60"
                .ReminderMinutesBeforeStart = 10
                .ReminderPlaySound = True
                .ReminderSet = True
                .Save
            End With
            Set objTermin = Nothing
        End If
    Next lngRow
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set objFolder = Nothing
    Set objTermin = Nothing
    Set objOutApp = Nothing
    If Err.Number = 0 Then MsgBox "Termine nach Outlook übertragen!"
End Sub
Private Function fncPointExist(ByVal objTMP As Object, _
    ByVal strSubject As String) As Boolean
    Dim objItem As Object
    For Each objItem In objTMP.Items
        If objItem.Subject = strSubject Then fncPointExist = True
    Next
End Function

Änderunsfrage: Jetzt steht das Datum in Spalte F, Subject soll immer gleich sein und der Body soll geprüft werden - der steht in Spalte C. Wie geht das?

Option Explicit
Sub Excel_Control_Termin_nach_Outlook()
    Dim wksSheet As Worksheet
    Dim objFolder As Object
    Dim objOutApp As Object
    Dim objTermin As Object
    Dim lngRow As Long
    On Error GoTo Fin
    Set wksSheet = ThisWorkbook.Worksheets("Roadmap AUDIT") ' Anpassen!!!
    Set objOutApp = CreateObject("Outlook.Application")
    '9 = olFolderCalendar
    Set objFolder = objOutApp.GetNamespace("MAPI").GetDefaultFolder(9)
    For lngRow = 1 To wksSheet.Cells(Rows.Count, 6).End(xlUp).Row
        If Not fncPointExist(objFolder, wksSheet.Cells(lngRow, 3).Value) And _
            IsDate(wksSheet.Cells(lngRow, 6).Value) Then
            Set objTermin = objOutApp.CreateItem(1)
            With objTermin
                .Start = Format(wksSheet.Cells(lngRow, 6).Value _
                    + 1, "dd.mm.yyyy") & " 10:00"
                .Subject = "Reminder AUDIT-Issue"
                .Body = wksSheet.Cells(lngRow, 3).Value
                .Location = "tbd"
                .Duration = "30"
                .ReminderMinutesBeforeStart = 10
                .ReminderPlaySound = True
                .ReminderSet = True
                .Save
            End With
            Set objTermin = Nothing
        End If
    Next lngRow
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set objFolder = Nothing
    Set objTermin = Nothing
    Set objOutApp = Nothing
    If Err.Number = 0 Then MsgBox "Termine nach Outlook übertragen!"
End Sub
Private Function fncPointExist(ByVal objTMP As Object, _
    ByVal strBody As String) As Boolean
    Dim objItem As Object
    For Each objItem In objTMP.Items
        If objItem.Body = strBody Then fncPointExist = True
    Next
End Function

Ordner erstellen - Datei kopieren

Frage: Wenn ich in F5 etwas eingebe, soll unter einem festgelegten Pfad ein Ordner erstellt werden. Der Name des Ordners soll "P" plus der Inhalt von F5 sein. Die Datei soll gleich in diesen Ordner gespeichert werden - Name auch "P" plus der Inhalt von F5. Wie geht das?

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
' Pfad bzw. Laufwerkbuchstabe anpassen!!!
Const strPath As String = "C:\Temp\2012\Projecten\P"
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim strTMP As String
    On Error GoTo Fin
    If Target.Address = "$F$5" Then
        Application.EnableEvents = False
        strTMP = strPath & Right(Target.Value, _
            (Len(Target.Value)))
            Target.Offset(1, 0).Value = Now()
            MakeSureDirectoryPathExists (strTMP & "\")
        ActiveWorkbook.SaveAs Filename:= _
            strTMP & "\" & _
            Mid(strTMP, InStrRev(strTMP, "\", -1) + 1), _
            FileFormat:=xlNormal
    End If
Fin:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Datei suchen - Tabellenblatt kopieren

Frage: In meiner Datei habe ich auf einem Tabellenblatt einen Button. Wenn ich da drauf klicke, soll folgendes passieren:

1. Eine InputBox fragt nach einem Dateinamen.
2. Diese wird in einem Ordner (inklusive Unterordner) gesucht.
3. Wenn gefunden, dann geöffnet, sonst MsgBox.
4. Aus der Datei mit dem Button soll dann ein bestimmtes Tabellenblatt in die geöffnete Datei ans Ende kopiert werden und den Namen aus der InputBox erhalten.

Wie geht das?

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, _
    ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
Const strPath As String = "C:\Temp\"
Const strEx As String = ".xlsx"
Sub Test_1()
    Dim strPathName As String * 255
    Dim wkbBook As Workbook
    Dim strSearch As String
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    On Error GoTo Fin
    strSearch = InputBox("Bitte Nr eingeben:", "Datei", "123-456")
    If Trim(strSearch) = "" Then Exit Sub
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    lngTMP = SearchTreeForFile(strPath, strSearch & strEx, strPathName)
    If lngTMP = 0 Then
        MsgBox "Datei nicht vorhanden"
    Else
        strPathName = Left$(strPathName, _
            InStr(1, strPathName, vbNullChar) - 1)
        strName = RTrim(strPathName)
        Set wkbBook = Workbooks.Open(strName)
        With wkbBook
            If fncSheet(.Name, strSearch) = False Then
                ThisWorkbook.Worksheets("Tabelle3").Copy _
                    After:=.Worksheets(.Worksheets.Count)
                .Worksheets(.Worksheets.Count).Name = strSearch
            Else
                MsgBox "Tabellenblatt schon vorhanden!"
            End If
        End With
        wkbBook.Close True
    End If
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    Set wkbBook = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function fncSheet(ByVal strFile As String, _
    ByVal strSheet As String) As Boolean
    Dim objWorksheet As Worksheet
      For Each objWorksheet In Workbooks(strFile).Worksheets
        If objWorksheet.Name = strSheet Then fncSheet = True: Exit For
      Next objWorksheet
End Function

Ordner kopieren und umbenennen

Frage: Ich möchte einen bekannten Ordner "ZZZ" mit seinem Inhalt von einem bestimmten Ort "C:\Hallo" an einen anderen bestimmten Ort kopieren z.B. "D:\Hallo".
Dort muss dann der Ordnername von "ZZZ" in "YYY "umbenannt werden.
Im kopierten Ordner befindet sich eine Excel Datei, die dann in "aaa.xls" umbenannt werden soll. Wie geht das?

Option Explicit
' Die vier Konstanten anpassen!!!
Const strFolderPath As String = "C:\Temp\"
Const strFolderQ As String = "Test\"
Const strFolderZ As String = "E:\Software\"
Const strFolderZNew As String = "Fertig\"
Public Sub Main()
    Dim objFolder As Object
    Dim objFSO As Object
    On Error GoTo Fin
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.Getfolder(strFolderPath & strFolderQ)
    objFolder.Copy (strFolderZ)
    ' Name TestMappe.xls anpassen!!!
    Name strFolderZ & strFolderQ & "TestMappe.xls" As _
        strFolderZ & strFolderQ & "Irgendwas.xls"
    Name strFolderZ & strFolderQ As strFolderZ & strFolderZNew
Fin:
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
    Set objFolder = Nothing
    Set objFSO = Nothing
End Sub

Formeln auf einer UserForm in einer TextBox darstellen...

Formeln auf einer UserForm in einer TextBox anzeigen. Z. B. "Formula", "FormulaLocal"... und wie muss die Formel in VBA ...