29.01.2013

Datei suchen - Pfad unbekannt - Hyperlink - API...

Frage: Zwei Dinge - zum Einen habe ich eine Liste mit Dateinamen in Spalte A, zum Zweiten möchte ich den Dateinamen in Zelle A1 eingeben. Der Speicherort der jeweiligen Datei ist nicht bekannt. Ein Hyperlink soll in Spalte B eingefügt werden. Optional möchte ich die Dateien in ein Verzeichnis mit Ordnerauswahl kopieren. Wie geht das?

Two things - first I have a list of file names in column A, secondly I would like to enter the file name in cell A1. The location of the file is unknown. A hyperlink will be inserted in column B. Optional I want to copy the files into a folder with folder selection. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Datei suchen - Pfad unbekannt - Hyperlink - API...[ZIP 3 MB]

Code gehört in Sheet1 / Code belongs in Sheet1:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Sheet1 
' Procedure : Worksheet_Change 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Wenn nicht mehr als eine Zelle gewählt wurde, dann... 
    If Not Target.Count > 1 Then
        ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
        With Application
            ' Das Bildschirmaktualisierung wird unterbrochen 
            .ScreenUpdating = False
            ' Ereignisroutinen werden deaktiviert 
            .EnableEvents = False
            ' Auslesen der momentanen Einstellung für die Berechnung 
            lngCalc = .Calculation
            ' Setzen der Berechnung auf "Manuell" 
            .Calculation = xlCalculationManual
            '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
            .DisplayAlerts = False
        End With
        ' Wenn es A1 ist dann... 
        If Target.Address(False, False) = "A1" Then
            ' Wenn A1 nicht leer ist, dann... 
            If Trim(Target.Value) <> "" Then
                ' Variable lngTMP <> 0 - Datei ist vorhanden 
                lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                    Application.PathSeparator, Target.Text, strPathName)
                ' Variable lngTMP = 0 - Datei nicht vorhanden 
                If lngTMP = 0 Then
                    MsgBox "File not found!", vbInformation, "Info"
                Else
                    ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                    strPathName = Left$(strPathName, _
                        InStr(1, strPathName, vbNullChar) - 1)
                    strName = RTrim(strPathName)
                    ' In B1 schreiben 
                    Target.Offset(, 1).Value = strName
                    ' Hyperlink in B1 auf gefundene Datei setzen 
                    Target.Offset(, 1).Hyperlinks.Add _
                        Anchor:=Target.Offset(, 1), Address:=strName
                End If
            Else
                ' sonst - A1 ist leer, also lösche B1 
                Target.Offset(, 1).Clear
            End If
        End If
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code gehört in Sheet2 / Code belongs in Sheet2:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Sheet2 
' Procedure : Worksheet_Change 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
' Dateierweiterung gegebenenfalls anpassen!!! 
Const strEX As String = ".pdf"
Private Sub Worksheet_Change(ByVal Target As Range)
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Wenn nicht mehr als eine Zelle gewählt wurde, dann... 
    If Not Target.Count > 1 Then
        ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
        With Application
            ' Das Bildschirmaktualisierung wird unterbrochen 
            .ScreenUpdating = False
            ' Ereignisroutinen werden deaktiviert 
            .EnableEvents = False
            ' Auslesen der momentanen Einstellung für die Berechnung 
            lngCalc = .Calculation
            ' Setzen der Berechnung auf "Manuell" 
            .Calculation = xlCalculationManual
            '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
            .DisplayAlerts = False
        End With
        ' Wenn es A1 ist dann... 
        If Target.Address(False, False) = "A1" Then
            ' Wenn A1 nicht leer ist, dann... 
            If Trim(Target.Value) <> "" Then
                ' Variable lngTMP <> 0 - Datei ist vorhanden 
                lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                    Application.PathSeparator, Target.Text & strEX, strPathName)
                ' Variable lngTMP = 0 - Datei nicht vorhanden 
                If lngTMP = 0 Then
                    MsgBox "File not found!", vbInformation, "Info"
                Else
                    ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                    strPathName = Left$(strPathName, _
                        InStr(1, strPathName, vbNullChar) - 1)
                    strName = RTrim(strPathName)
                    ' In B1 schreiben 
                    Target.Offset(, 1).Value = strName
                    ' Hyperlink in B1 auf gefundene Datei setzen 
                    Target.Offset(, 1).Hyperlinks.Add _
                        Anchor:=Target.Offset(, 1), Address:=strName
                End If
            Else
                ' sonst - A1 ist leer, also lösche B1 
                Target.Offset(, 1).Clear
            End If
        End If
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
' Dateierweiterung gegebenenfalls anpassen!!! 
Const strEX As String = ".pdf"
Public Sub Main()
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim lngLastRow As Long
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Sheet3 ist der CODENAME / OBJEKTNAME eines Tabellenblattes 
    ' in einem englischen Excel 
    ' In deutsch dann Tabelle3 
    With Sheet3
        ' Letzte Teile Spalte A ermitteln 
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        ' Schleife über Zeilen 
        For lngLastRow = 1 To lngLastRow
            ' Variable lngTMP <> 0 - Datei ist vorhanden 
            lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                Application.PathSeparator, .Cells(lngLastRow, 1).Text & _
                strEX, strPathName)
            ' Variable lngTMP = 0 - Datei nicht vorhanden 
            If lngTMP = 0 Then
                ' Text in Spalte B schreiben 
                .Cells(lngLastRow, 2).Value = "File not found!"
            Else
                ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                strPathName = Left$(strPathName, _
                    InStr(1, strPathName, vbNullChar) - 1)
                strName = RTrim(strPathName)
                ' In B schreiben 
                .Cells(lngLastRow, 2).Value = strName
                ' Hyperlink in B auf gefundene Datei setzen 
                .Cells(lngLastRow, 2).Hyperlinks.Add _
                    Anchor:=.Cells(lngLastRow, 2), Address:=strName
            End If
        ' Nächste Zeile 
        Next lngLastRow
        ' Spalte A und B optimale Breite einstellen 
        .Columns("A:B").AutoFit
    End With
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code gehört in ein Modul / Code belongs in a module:

Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : File Search - location unknown - API... 
'-------------------------------------------------------------------------- 
' Dateierweiterung gegebenenfalls anpassen!!! 
Const strEX As String = ".pdf"
Public Sub Main_1()
    ' Variablendeklaration 
    ' Stringvariable mit Puffer 
    Dim strPathName As String * 255
    Dim strDestFolder As String
    Dim lngLastRow As Long
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    If fncFolder(strDestFolder) <> "" Then
        ' Sheet3 ist der CODENAME / OBJEKTNAME eines Tabellenblattes 
        ' in einem englischen Excel 
        ' In deutsch dann Tabelle3 
        With Sheet3
            ' Letzte Teile Spalte A ermitteln 
            lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            ' Schleife über Zeilen 
            For lngLastRow = 1 To lngLastRow
                ' Variable lngTMP <> 0 - Datei ist vorhanden 
                lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
                    Application.PathSeparator, .Cells(lngLastRow, 1).Text & _
                    strEX, strPathName)
                ' Variable lngTMP = 0 - Datei nicht vorhanden 
                If lngTMP = 0 Then
                    ' Text in Spalte B schreiben 
                    .Cells(lngLastRow, 3).Value = "Not copied!"
                Else
                    ' Puffer zurechtstutzen, überflüssige Leerzeichen weg 
                    strPathName = Left$(strPathName, _
                        InStr(1, strPathName, vbNullChar) - 1)
                    strName = RTrim(strPathName)
                    FileCopy strName, strDestFolder & Mid(strName, _
                        InStrRev(strName, "\", -1) + 1)
                End If
            ' Nächste Zeile 
            Next lngLastRow
            ' Spalte A, B und C optimale Breite einstellen 
            .Columns("A:C").AutoFit
        End With
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : fncFolder 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 29.01.2013 
' Purpose   : Folder selection... 
'-------------------------------------------------------------------------- 
Private Function fncFolder(strTMPFolder As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Folder"
        .ButtonName = "Choice..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strTMPFolder = .SelectedItems(1)
            strTMPFolder = IIf(Right(strTMPFolder, 1) <> "\", _
                strTMPFolder & "\", strTMPFolder)
        Else
            fncFolder = ""
        End If
    End With
    fncFolder = strTMPFolder
End Function

28.01.2013

Excel - Word - vertikal verbundene Zellen - Tabelle - Zeile löschen...

Frage: Von einem Exceldokument wird ein bestimmter Bereich nach Word kopiert. Dieser beinhaltet vertikal verbundene Zellen. Das löschen einer Zeile dieser Tabelle mit "Rows(2).Delete" scheitert. Wie geht das?

From an Excel document a particular range is copied to Word. This includes vertically merged cells. Delete a row in this table with "Rows(2).Delete" fails. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Excel - Word - vertikal verbundene Zellen - Tabelle - Zeile löschen...[XLS 40 KB]

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.01.2013 
' Purpose   : Excel to Word with vertically merged cells... 
'-------------------------------------------------------------------------- 
Const wdDeleteCellsEntireRow = 2
Public Sub Main()
    Dim strBookmark As String
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Die Wordapplikation sichtbar starten 
    Set objWDApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objWDApp Is Nothing Then
        ' Name der Textmarke 
        strBookmark = "Test"
        ' Ein neues Worddokument erstellen 
        Set objWDDoc = objWDApp.Documents.Add
        ' Diese Zeile ist eigentlich blödsinnig, denn in einem 
        ' neuen Dokument kann keine Textmarke / Bookmark sein 
        ' Aber man sieht, wie auf eine Textmarke geprüft werden kann 
        ' Und wie eine Textmarke hinzugefügt wird 
        If Not objWDDoc.Bookmarks.Exists(strBookmark) = True Then
            objWDDoc.Bookmarks.Add Name:=strBookmark
            ' Bereich der kopiert werden soll 
            ' Sheet1 ist der Codename eines Tabellenblattes 
            ' in einem englischen Excel 
            ' In deutsch dann Tabelle1 
            Sheet1.Range("A1:E4").Copy
            ' Aus dem Objektkatalog von Word im VBA-Editor (F2) 
            ' Sub PasteExcelTable(LinkedToExcel As Boolean, 
            ' WordFormatting As Boolean, RTF As Boolean) 
            objWDDoc.Bookmarks(strBookmark).Range.PasteExcelTable _
                False, False, False
            ' Wenn alles läuft diese Zeile entfernen, ist nur zum testen 
            Stop
            ' Zeile 2 wird gelöscht. Vertikal verbundene Zellen sind vorhanden 
            ' das funktioniert auch, wenn keine 
            ' verbundenen Zellen vorhanden sind 
            objWDDoc.Tables(1).Cell(2, 1).Delete wdDeleteCellsEntireRow
        End If
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 28.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String) 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")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

24.01.2013

PowerPoint - New Presentation - Slide add - TextFrame...

Frage: Ich möchte In Powerpoint Rechtecke erzeugen und Text reinschreiben. Wie geht das?

I want to create in PowerPoint rectangles and write in text. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
PowerPoint - New Presentation - Slide add - TextFrame...[XLS 40 KB]

Option Explicit
' Leeres Slide in PowerPoint 
Const ppLayoutBlank As Long = 12
' Objektvariable für Applikation 
Dim objPP As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : PowerPoint - New Presentation - Slide add - TextFrame... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Variablendeklaration 
    Dim intHeight As Integer
    Dim intWidth As Integer
    Dim intCount As Integer
    Dim objPPDoc As Object
    Dim intLeft As Integer
    Dim intTop As Integer
    Dim intTMP As Integer
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Abmasse bzw. der Abstand 
    intHeight = 60
    intWidth = 100
    intCount = 10
    intLeft = 10
    intTop = 10
    ' PowerPoint starten 
    ' Wenn PowerPoint ausgeblendet werden soll, dann so: 
    ' http://vbanet.blogspot.de/2010/09/excel-powerpoint.html 
    Set objPP = OffApp("PowerPoint")
    If Not objPP Is Nothing Then
        With objPP
            ' Neue Präsentation 
            .Presentations.Add
            ' Neues LEERES Slide 
            .ActivePresentation.Slides.Add 1, ppLayoutBlank
            Set objPPDoc = .ActivePresentation.Slides(1)
        End With
        For intTMP = 1 To 5
            ' Shape Rechteck hinzufügen 
            With objPPDoc.Shapes.AddShape _
                (msoShapeRectangle, 0, 0, intWidth, intHeight)
                ' Text reinschreiben 
                .TextFrame.TextRange.Text = "Test " & intTMP
                ' Schriftgrösse 
                .TextFrame.TextRange.Font.Size = 14
                ' Abstand oben 
                .Top = intCount
                ' Abstand links 
                .Left = intLeft
                ' Für die nächste Plazierung hochzählen 
                intCount = intCount + .Height + intTop
            End With
        Next intTMP
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objPPDoc = Nothing
    Set objPP = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    On Error Resume Next
    Set objPP = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objPP = CreateObject(strApp & ".Application")
            If blnVisible = True Then
                On Error Resume Next
                objPP.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objPP
    Set objPP = Nothing
End Function

Word - Tabelle erstellen - Zeile löschen - Daten kopieren...

Frage: Nachfolgend ein paar Beispiele wie man in Word Tabellen erstellt, Zeilen in der Tabelle löscht, einen Zellbereich nach Word kopiert - natürlich alles aus Excel. Kommentare im Code.

Here are a few examples of how to create tables in Word, delete rows in the table, copying a range of cells to Word - of course everything from Excel. Comments in the code.

Hier noch eine Beispieldatei / Here's a sample file:
Word - Tabelle erstellen - Zeile löschen - Daten kopieren...[ZIP 50 KB]

Code gehört in ein Modul (Module1) / Code belongs in a module (Module1):

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Open Word from Excel insert data and delete table row... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim varRange As Variant
    Dim objTable As Object
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Die Wordapplikation sichtbar starten 
    Set objWDApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objWDApp Is Nothing Then
        ' Den Kopierbereich zuweisen 
        varRange = Sheet1.Range("A1:E4").Value
        ' Das Worddokument MIT Tabelle öffnen 
        Set objWDDoc = objWDApp.Documents.Open(ThisWorkbook.Path & _
            Application.PathSeparator & "Test_document_with_a_table.doc")
        ' Die erste Tabelle einer Objektvariablen zuweisen 
        Set objTable = objWDDoc.Tables(1)
        With objTable
            ' Die Daten in Schleifen eintragen 
            For intCount1 = 1 To Ubound(varRange, 1)
                For intCount2 = 1 To Ubound(varRange, 2)
                    .Cell(intCount1, intCount2).Range.InsertAfter _
                        varRange(intCount1, intCount2)
                Next intCount2
            Next intCount1
            ' Der Code stoppt hier. Jetzt die Worddatei anschauen 
            ' Diese Zeile kann/muss natürlich später raus - ist nur zum testen 
            Stop
            ' Die zweite Zeile der Wordtabelle wird gelöscht 
            .Rows(2).Delete
        End With
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objTable = Nothing
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String) 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")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Code gehört in ein Modul (Module2) / Code belongs in a module (Module2):

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Open Word from Excel insert data and delete table row... 
'-------------------------------------------------------------------------- 
Public Sub Main_1()
    Dim intCount1 As Integer
    Dim intCount2 As Integer
    Dim varRange As Variant
    Dim objTable As Object
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim lngCalc As Long
    Const wdStory = 6
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Die Wordapplikation sichtbar starten 
    Set objWDApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objWDApp Is Nothing Then
        ' Den Kopierbereich zuweisen 
        varRange = Sheet1.Range("A1:E4").Value
        ' Das Worddokument OHNE Tabelle öffnen 
        Set objWDDoc = objWDApp.Documents.Open(ThisWorkbook.Path & _
            Application.PathSeparator & "Test_document_without_a_table.doc")
        ' Gehe ans Ende des Dokumentes 
        objWDApp.Selection.EndOf wdStory
        ' Die Objektvariable wird mit einer neu erstellten Tabelle gefüllt 
        Set objTable = objWDDoc.Tables.Add(objWDApp.Selection.Range, _
            Ubound(varRange, 1), Ubound(varRange, 2))
        With objTable
            ' Die Daten in Schleifen eintragen 
            For intCount1 = 1 To Ubound(varRange, 1)
                For intCount2 = 1 To Ubound(varRange, 2)
                    .Cell(intCount1, intCount2).Range.InsertAfter _
                        varRange(intCount1, intCount2)
                Next intCount2
            Next intCount1
            ' Der Code stoppt hier. Jetzt die Worddatei anschauen 
            ' Diese Zeile kann/muss natürlich später raus - ist nur zum testen 
            Stop
            ' Die zweite Zeile der Wordtabelle wird gelöscht 
            .Rows(2).Delete
        End With
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objTable = Nothing
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String) 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")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

Code gehört in ein Modul (Module3) / Code belongs in a module (Module3):

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Module3 
' Procedure : Main_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Open Word from Excel insert data... 
'-------------------------------------------------------------------------- 
Public Sub Main_2()
    Dim strBookmark As String
    Dim objWDApp As Object
    Dim objWDDoc As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Die Wordapplikation sichtbar starten 
    Set objWDApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objWDApp Is Nothing Then
        ' Name der Textmarke 
        strBookmark = "Test"
        ' Ein neues Worddokument erstellen 
        Set objWDDoc = objWDApp.Documents.Add
        ' Diese Zeile ist eigentlich blödsinnig, denn in einem 
        ' neuen Dokument kann keine Textmarke / Bookmark sein 
        ' Aber man sieht, wie auf eine Textmarke geprüft werden kann 
        ' Und wie eine Textmarke hinzugefügt wird 
        If Not objWDDoc.Bookmarks.Exists(strBookmark) = True Then
            objWDDoc.Bookmarks.Add Name:=strBookmark
            ' Bereich der kopiert werden soll 
            Sheet1.Range("A1:E4").Copy
            ' Aus dem Objektkatalog von Word im VBA-Editor (F2) 
            ' Sub PasteExcelTable(LinkedToExcel As Boolean, 
            ' WordFormatting As Boolean, RTF As Boolean) 
            objWDDoc.Bookmarks(strBookmark).Range.PasteExcelTable _
                False, False, False
        End If
    End If
Fin:
    ' Objektvariablen zurücksetzen 
    Set objWDDoc = Nothing
    Set objWDApp = Nothing
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Module3 
' Procedure : OffApp 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 24.01.2013 
' Purpose   : Start application... 
'-------------------------------------------------------------------------- 
Private Function OffApp(ByVal strApp As String) 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")
            objApp.Visible = True
            If Err.Number > 0 Then
                MsgBox Err.Number & " " & Err.Description
                Set objApp = Nothing
            End If
        Case 0
        Case Else
            MsgBox Err.Number & " " & Err.Description
            Set objApp = Nothing
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

23.01.2013

Chartsheets mit Bedingung kopieren, die 2te...

Frage: Es gibt eine Reihe von Diagrammblätter (ChartSheets). Wenn eines dieser Diagrammblätter einen bestimmten String im Namen hat, wird das jeweilige Diagramm in ein neu erstelltes Tabellenblatt kopiert - ABER ALS DIAGRAMM. Wird der Code erneut ausgeführt, wird das neu erstellte Tabellenblatt samt den darin enthaltenen Diagrammen gelöscht. Wie geht das?

There are a number of chart sheets (chart sheets). If any of these chart sheets has a certain string in the name, the appropriate chart sheet is copied to a newly created spreadsheet - BUT AS A CHART. If the code is executed again, the newly created spreadsheet including the contained diagrams will be deleted. How does it work?

Mit einer kleinen Codeänderung funktioniert das / With a small code change works:

Hier noch eine Beispieldatei / Here's a sample file:
Chartsheets mit Bedingung kopieren, die 2te...[XLS 90 KB]

Option Explicit
' Der Abstand von Oben und zwischen den Diagrammen 
Const intAbove As Integer = 20
' Der Abstand vom linken Rand 
Const intLeft As Integer = 50
' Dieser Begriff MUSS IRGENDWO im ChartSheet - Namen vorkommen 
' damit das enthaltene Diagramm kopiert wird 
Const strTerm As String = "Test"
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Chart_Copy_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.01.2013 
' Purpose   : Chartsheets kopieren, wenn String in Sheetname vorhanden... 
'-------------------------------------------------------------------------- 
Sub Chart_Copy_2()
    ' Deklarieren der Variablen 
    Dim intChartHeight As Integer
    Dim shpShapeTarget As Shape
    Dim objSheet As Object
    Dim lngCalc As Long
    Dim lngTMP As Long
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten 
    With Application
        ' Das Bildschirmaktualisierung wird unterbrochen 
        .ScreenUpdating = False
        ' Ereignisroutinen werden deaktiviert 
        .EnableEvents = False
        ' Auslesen der momentanen Einstellung für die Berechnung 
        lngCalc = .Calculation
        ' Setzen der Berechnung auf "Manuell" 
        .Calculation = xlCalculationManual
        '  Eingabeaufforderungen und Warnmeldungen unterdrücken 
        .DisplayAlerts = False
    End With
    ' Bequemlichkeit beim löschen eines 
    ' eventuell nicht vorhandenen Tabellenblattes 
    On Error Resume Next
    Worksheets(strTerm).Delete
    ' Deaktiviert die Fehlerbehandlung in der aktuellen Prozedur 
    On Error GoTo 0
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Tabellenblatt hinzufügen und gleich einen Namen vergeben 
    Worksheets.Add.Name = strTerm
    ' Schleife für jedes Tabellenblatt in dieser Datei 
    For Each objSheet In ThisWorkbook.Sheets
        ' Wenn es ein ChartSheet ist, dann... 
        If TypeOf objSheet Is Chart Then
            ' Wenn der Tabellenblattname den Begriff 
            ' irgendwo enthält, dann... 
            If InStr(1, objSheet.Name, strTerm, vbTextCompare) > 0 Then
                ' Kopiere es als Diagramm 
                objSheet.ChartArea.Copy
                ' Und füge es im neu erstellten Tabellenblatt ein 
                With Worksheets(strTerm)
                    .Paste
                    ' Das eingefügte Bild einer Objektvariablen zuweisen 
                    Set shpShapeTarget = .Shapes(.Shapes.Count)
                    With shpShapeTarget
                        ' Den Abstand von Oben setzen 
                        .Top = intAbove + intChartHeight
                        ' Den Abstand von Links setzen 
                        .Left = intLeft
                    End With
                    ' Hochrechnen 
                    intChartHeight = intChartHeight _
                        + shpShapeTarget.Height + intAbove
                End With
                ' Objektvariable zurücksetzen 
                Set shpShapeTarget = Nothing
            End If
        End If
    Next objSheet
    Application.Goto ThisWorkbook.Worksheets(strTerm).Range("A1"), True
Fin:
    ' Objektvariable zurücksetzen 
    Set shpShapeTarget = Nothing
    ' Die Applikation aufwecken 
    With Application
        ' Bildschirmaktualisierung wieder einschalten 
        .ScreenUpdating = True
        ' Ereignisroutinen werden wieder aktiviert 
        .EnableEvents = True
        ' Setzen der Berechnung auf den gemerkten Wert 
        .Calculation = lngCalc
        ' Eingabeaufforderungen und Warnmeldungen wieder zulassen 
        .DisplayAlerts = True
        ' Abbrechen Ausschneide- bzw. Kopiermodus und entfernen des Laufrahmens 
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
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 ...