01.10.2019

Spielerei mit Formeln - Ausgabe der Berechnungsschritte...

Spielerei mit Formeln. Eingegebene Berechnungen ausrechnen. Entweder in der gleichen Zelle, oder rechts daneben.

Play with formulas. Calculate entered calculations. Either in the same cell, or to the right.

Hier noch eine Beispieldatei / Here's a sample file:
Spielerei mit Formeln - Ausgabe der Berechnungsschritte...[XLSB 25 KB]

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

Option Explicit
'--------------------------------------------------------------------------
' Module    : Tabelle1
' Procedure : Worksheet_Change
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.10.2019
' Purpose   : Spielerei mit Formeln...
'--------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fin
    Application.EnableEvents = False
    If Not Intersect(Target, Range("C12:C20")) Is Nothing And Target.CountLarge = 1 Then
        Target.NumberFormat = "@"
        Call Main_2(Target.Text, Target.Address)
    ElseIf Not Intersect(Target, Range("H12:H20")) Is Nothing And Target.CountLarge = 1 Then
        If Trim(Target.Value) <> "" Then
            Target.NumberFormat = "@"
            Call Main_3(Target.Text, Target.Address)
        Else
            Target.Offset(, 1).ClearContents
        End If
    End If
Fin:
    Application.EnableEvents = True
End Sub

Code gehört in Modul1 / Code belongs in Module1:

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.10.2019
' Purpose   : Spielerei mit Formeln - Ausgabe gleiche Zelle...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim rngRange As Range
    For Each rngRange In Selection
        If IsNumeric(Left(rngRange.Text, 1)) Then
            rngRange.NumberFormat = "General"
            rngRange = "=" & rngRange.Value
        End If
    Next rngRange
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.10.2019
' Purpose   : Spielerei mit Formeln - Ausgabe rechts daneben...
'--------------------------------------------------------------------------
Public Sub Main_1()
    Dim rngRange As Range
    For Each rngRange In Selection
        If IsNumeric(Left(rngRange.Text, 1)) Then
            rngRange.Offset(, 1).NumberFormat = "General"
            rngRange.Offset(, 1) = "=" & rngRange.Value
        End If
    Next rngRange
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main_2
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.10.2019
' Purpose   : Spielerei mit Formeln - Ausgabe für gelben Bereich...
'--------------------------------------------------------------------------
Public Sub Main_2(ByVal strTMP As String, ByVal strAddress As String)
    If IsNumeric(Left(strTMP, 1)) Then
        Range(strAddress).NumberFormat = "General"
        Range(strAddress).Value = "=" & Range(strAddress).Value
    End If
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main_3
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.10.2019
' Purpose   : Spielerei mit Formeln - Ausgabe für blauen Bereich...
'--------------------------------------------------------------------------
Public Sub Main_3(ByVal strTMP As String, ByVal strAddress As String)
    If IsNumeric(Left(strTMP, 1)) Then
        Range(strAddress).Offset(, 1).NumberFormat = "General"
        Range(strAddress).Offset(, 1).Value = "=" & Range(strAddress).Value
    End If
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Los
' Author    : Case (Ralf Stolzenburg)
' Date      : 01.10.2019
' Purpose   : Spielerei mit Formeln - Ausgangszustand...
'--------------------------------------------------------------------------
Public Sub Los()
    Tabelle1.Range("A1:B6").ClearContents
    Tabelle1.Range("C12:C20").ClearContents
    Tabelle1.Range("H12:H20").ClearContents
    Tabelle2.Range("A1:A6").Copy Tabelle1.Range("A1:A5"): Application.CutCopyMode = True
    Tabelle1.Range("A1:A6").Select
End Sub

17.08.2019

Bilder im Tabellenblatt permanent einfügen - nicht nur verlinken...

Bilder in Tabellenblatt permanent einfügen - nicht verlinkt, damit die Datei weitergegeben werden kann. Zum ermitteln des Speicherpfades wird ENVIRON genommen (Codezeile ist nicht aktiv). Im Beispiel wird der Pfad genommen, in welcher die Datei mit dem Code liegt - also bei Bedarf anpassen. Alle ENVIRON - Variablen werden zur Information in einer neuen Datei angezeigt.

Insert images into spreadsheet permanently - not linked, so the file can be passed on. ENVIRON is used to determine the storage path (code line is not active). In the example, the path is taken in which the file with the code is located - i.e. adapt it if necessary. All ENVIRON variables are displayed in a new file for information purposes.

Hier noch eine Beispieldatei / Here's a sample file:
Bilder im Tabellenblatt permanent einfügen - nicht nur verlinken...[ZIP 265 KB]

Code gehört in Modul1 / Code belongs in Module1:

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 17.08.2019
' Purpose   : Bilder in Tabellenblatt einfügen, nicht nur verlinkt...
'--------------------------------------------------------------------------
' Tabelle1 ist der CODENAME des Tabellenblattes - siehe...
' https://vbanet.blogspot.com/search/label/Codename
Public Sub Main()
    ' Deklaration der Variablen und Konstanten - siehe...
    ' https://vbanet.blogspot.com/search/label/Variable
    ' https://de.wikibooks.org/wiki/VBA_in_Excel/_Variablen_und_Arrays
    Const strExt As String = ".jpg"
    Dim strFile As String
    Dim strPath As String
    Dim objPic As Shape
    Dim lngCalc As Long
    Dim lngRow As Long
    ' ENVIRON - siehe Modul2!!!!
    ' Auf die richtige Anzahl der Backslash "\" achten!!!!
    'strPath = Environ("UserProfile") & "\Desktop\USA - Kopie\"
    ' Pfad wie Datei mit dem Makro - darin dann Unterordner \Images
    ' Auf die richtige Anzahl der Backslash "\" achten!!!!
    strPath = ThisWorkbook.Path & Application.PathSeparator & "Images\"
     ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Alle Shapes/Bilder aus Spalte B löschen
    For Each objPic In Tabelle1.Shapes
        If Not Intersect(objPic.TopLeftCell, Range("B:B")) Is Nothing Then
            objPic.Delete
        End If
    Next objPic
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt Tabelle1 (CodeName des Tabellenblattes
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    ' siehe auch Hinweis zu CodeName ganz oben!!!!
    With Tabelle1
        ' Letzte belegte Zelle in Spalte A ermitteln
        lngRow = Application.Max(1, .Cells(.Rows.Count, 1).End(xlUp).Row)
        ' Schleife von Zelle 2 bis Ende
        For lngRow = 2 To lngRow
            ' Zelle ist nicht leer dann...
            If Not IsEmpty(.Cells(lngRow, 1).Value) Then
                ' Datei mit Pfad, Name und Extension auswählen
                strFile = Dir$(strPath & .Cells(lngRow, 1).Value & strExt, vbNormal)
                ' Wenn Datei vorhanden dann...
                If strFile <> "" Then
                    ' Bild in Spalte B, korrespondierene Zeile mit Höhe und Breite
                    ' der entsprechenden Zelle einfügen
                    Set objPic = .Shapes.AddPicture(Filename:=strPath & strFile, _
                        LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                        Left:=.Cells(lngRow, 2).Left + 1, Top:=.Cells(lngRow, 2).Top + 1, _
                        Width:=.Cells(lngRow, 2).Width, Height:=.Cells(lngRow, 2).Height)
                    ' Seitenverhältnis aufheben um unabhängige Höhe und Breite anzugeben
                    ' objPic.LockAspectRatio = False
                    ' objPic.Height = .Cells(lngRow, 2).Height
                    ' objPic.Width = dblOWidth * (objPic.Height / dblOHeight)
                End If
            End If
        Next lngRow
    End With
Fin:
    ' Objektvariable leeren
    Set objPic = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
End Sub

Code gehört in Modul2 / Code belongs in Module2:

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul2
' Procedure : Main_ENV
' Author    : Case (Ralf Stolzenburg)
' Date      : 17.08.2019
' Purpose   : Umgebungsvariablen ENVIRON ausgeben...
'--------------------------------------------------------------------------
' Alle ENVIRON - Variablen in neuem Workbook ausgeben!!!!
' https://docs.microsoft.com/de-de/office/vba/language/reference/user-interface-help/environ-function
Public Sub Main_ENV()
    Dim wkbBook As Workbook
    Dim strTMP() As String
    Dim lngTMP As Long
    On Error GoTo Fin
    lngTMP = 1
    Set wkbBook = Workbooks.Add(1)
    With wkbBook.Worksheets(lngTMP)
        Do
            strTMP = Split(Environ(lngTMP), "=")
            If Join(strTMP) <> "" Then
                .Cells(lngTMP, 1).Value = strTMP(0)
                .Cells(lngTMP, 2).Value = strTMP(1)
                lngTMP = lngTMP + 1
            End If
        Loop Until Join(strTMP) = ""
        .Columns("A:B").AutoFit
    End With
Fin:
    Set wkbBook = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & " " & Err.Description
End Sub

26.05.2019

Werte verteilen - drei Beispiele...

Werte von einem Tabellenblatt auf mehrere Tabellenblätter verteilen. Einmal mit Zahlen, dann mit Texten und schließlich werden die Tabellenblätter erstellt.

Distribute values from one worksheet to several worksheets. Once with numbers, then with texts and finally the spreadsheets are created.

Hier noch eine Beispieldatei / Here's a sample file:
Werte verteilen - drei Beispiele...[ZIP 33 KB]

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

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 26.05.2019
' Purpose   : Werte verteilen - Formel in Tabellenblätter schreiben
' Note      : Funktioniert erst ab Excel 2010
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim lngCalc As Long
    Dim lngTMP As Long
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt Tabelle1 (CodeName des Tabellenblattes
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With Tabelle1
        ' Ermittelt die letzte belegte Zelle in Spalte A
        lngRow = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
            .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    ' Schleife über die drei Tabellenblätter "Registerx"
    For lngTMP = 1 To 3
        ' WITH - alles bezieht such auf das jeweilige Tabellenblatt
        With ThisWorkbook.Worksheets("Register" & lngTMP)
            ' Verschachtelte WITH-Konstruktion
            With .Range(.Cells(2, 1), .Cells(lngRow, 7))
                ' Formel im ganzen Bereich eintragen
                .Formula = "=IFERROR(INDEX(Gesamt!A$2:A$" & lngRow & _
                    ",AGGREGATE(15,6,ROW($A$2:$A$" & lngRow & _
                    ")-1/(Gesamt!$C$2:$C$" & lngRow & "=" & lngTMP & _
                    "),ROW(A1))),"""")"
                ' Formel durch Werte ersetzen
                .Formula = .Value
            End With
        End With
    Next lngTMP
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

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

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 26.05.2019
' Purpose   : Werte verteilen - Formel in Tabellenblätter schreiben
' Note      : Funktioniert erst ab Excel 2010
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim varArr As Variant
    Dim lngCalc As Long
    Dim lngTMP As Long
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Array mit Werten die getrennt werden sollen befüllen
    ' Werte stehen im Beispiel in Spalte B
    ' Da es in der Formel ein String ist, müssen die
    ' Hochkommata entsprechend vervielfältigt werden
    varArr = Array("""Test1""", """Test2""", """Test3""")
    ' Man kann es auch so schreiben
    'varArr = Array(Chr(34) & "Test1" & Chr(34), Chr(34) & _
        "Test2" & Chr(34), Chr(34) & "Test3" & Chr(34))
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt Tabelle1 (CodeName des Tabellenblattes
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With Tabelle1
        ' Ermittelt die letzte belegte Zelle in Spalte A
        lngRow = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
            .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    ' Schleife über die drei Tabellenblätter "Registerx"
    For lngTMP = 1 To 3
        ' WITH - alles bezieht such auf das jeweilige Tabellenblatt
        With ThisWorkbook.Worksheets("Register" & lngTMP)
            ' Verschachtelte WITH-Konstruktion
            With .Range(.Cells(2, 1), .Cells(lngRow, 7))
                ' Formel im ganzen Bereich eintragen Werte stehen in Spalte B
                ' lngTMP - 1, da es ein 0-basiertes Array ist
                .Formula = "=IFERROR(INDEX(Gesamt!A$2:A$" & lngRow & _
                    ",AGGREGATE(15,6,ROW($A$2:$A$" & lngRow & _
                    ")-1/(Gesamt!$B$2:$B$" & lngRow & "=" & varArr(lngTMP - 1) & _
                    "),ROW(A1))),"""")"
                ' Formel durch Werte ersetzen
                .Formula = .Value
            End With
        End With
    Next lngTMP
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

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

Option Explicit
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 26.05.2019
' Purpose   : Werte verteilen - Formel in Tabellenblätter schreiben
' Note      : Funktioniert erst ab Excel 2010
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim wksTMP As Worksheet
    Dim varArr As Variant
    Dim lngRowZ As Long
    Dim lngCalc As Long
    Dim lngTMP As Long
    Dim lngRow As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    For Each wksTMP In ThisWorkbook.Worksheets
        ' Wenn mehr als 1 Tabellenblatt vorhanden ist, dann...
        If wksTMP.Index > 1 Then
            ' ... lösche es
            wksTMP.Delete
        End If
    Next wksTMP
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt Tabelle1 (CodeName des Tabellenblattes
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With Tabelle1
        ' Ermittelt die letzte belegte Zelle in Spalte A
        lngRow = IIf(Len(.Cells(.Rows.Count, 1)), .Rows.Count, _
            .Cells(.Rows.Count, 1).End(xlUp).Row)
        .Range("B1:B" & lngRow).AdvancedFilter _
            Action:=xlFilterCopy, _
            CopyToRange:=.Range("Z1"), Unique:=True
        lngRowZ = IIf(Len(.Cells(.Rows.Count, 26)), .Rows.Count, _
            .Cells(.Rows.Count, 26).End(xlUp).Row)
    ' Array mit Werten die getrennt werden sollen befüllen
    ' Werte stehen im Beispiel in Spalte Z
    varArr = Application.Transpose(Range("Z2:Z" & lngRowZ))
    ' Spalte Z wieder löschen
    .Columns("Z").Delete
    End With
    ' Schleife über die drei Tabellenblätter "Registerx"
    For lngTMP = 1 To UBound(varArr)
        ' WITH - alles bezieht such auf DIESES Workbook
        With ThisWorkbook
            ' Tabellenblatt hinzufügen und Name vergeben
            .Worksheets.Add After:= _
                .Worksheets(.Worksheets.Count)
            .Worksheets(.Worksheets.Count).Name = "Register" & lngTMP
        End With
        ' WITH - alles bezieht such auf das jeweilige Tabellenblatt
        With ThisWorkbook.Worksheets("Register" & lngTMP)
            ' Die Überschriftenzeile aus Tabelle Gesamt kopieren
            Tabelle1.Rows(1).Copy .Range("A1")
            ' Verschachtelte WITH-Konstruktion
            With .Range(.Cells(2, 1), .Cells(lngRow, 7))
                ' Formel im ganzen Bereich eintragen Werte in Spalte B
                ' Chr(34) weil es ein String sein muss
                .Formula = "=IFERROR(INDEX(Gesamt!A$2:A$" & lngRow & _
                    ",AGGREGATE(15,6,ROW($A$2:$A$" & lngRow & _
                    ")-1/(Gesamt!$B$2:$B$" & lngRow & "=" & _
                    Chr(34) & varArr(lngTMP) & Chr(34) & "),ROW(A1))),"""")"
                ' Formel durch Werte ersetzen
                .Formula = .Value
            End With
        End With
    Next lngTMP
Fin:
    ' Die Applikation aufwecken
    With Application
        ' Gehe zum Quelltabellenblatt nach A1
        .Goto Tabelle1.Range("A1"), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

20.05.2019

PDF-Dateien auslesen - dann umbenennen...

PDF Dateien werden nach Rechnung- und Kundennummer durchsucht. Die Datei wird nach diesen gefunden Werten umbenannt - plus Datum und Uhrzeit.

PDF files are searched by invoice number and customer number. The file is renamed according to these found values - including date and time.

Hier noch eine Beispieldatei / Here's a sample file:
PDF-Dateien auslesen - dann umbenennen...[ZIP 390 KB]

Option Explicit
' Wenn Word nicht offen ist wird diese Variable auf True
' gesetzt und Word am Ende wieder geschlossen
' War Word schon offen, beleibt es das auch
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.05.2019
' Purpose   : Aus PDF-Dateien etwas auslesen - Dokumente danach umbenennen
' Note      : Funktioniert erst ab Word 2013!!!!!!!!!!
'--------------------------------------------------------------------------
Public Sub Main()
    ' Dimensionieren der Variablen
    Dim objDocument As Object
    Dim strTrenn() As String
    Dim strDatei As String
    Dim strTMP1 As String
    Dim strTMP As String
    Dim objFSO As Object
    Dim objDir As Object
    Dim strDir As String
    Dim objApp As Object
    Dim lngCalc As Long
    Dim lngTMP As Long
    Dim lngRef As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        lngRef = Application.ReferenceStyle
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Wenn Du einen Ordnerauswahldialog möchtest
    'Set objShell = CreateObject("Shell.Application")
    'Set varDir = objShell.BrowseForFolder(0, "Ordner", &H4000, 17)
    'If varDir Is Nothing Then Set objShell = Nothing: Exit Sub
    'strDir = varDir.Self.Path
    ' Datei im gleichen Ordner wie Auswertungsdateien
    strDir = ThisWorkbook.Path
    'strDir = "C:\Temp\Los\"  ' Fester Pfad
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        strDatei = Dir$(strDir & "*.pdf", vbDirectory)
        Do While strDatei <> ""
            ' Word- Pdf-Dokument öffnen - ab Word 2013!!!!!
            Set objDocument = objApp.Documents.Open _
                (strDir & strDatei)
            ' Text an Leerzeichen trennen/aufsplitten
            strTrenn = Split(objDocument.Range, " ")
            ' Schleife über das Array von Anfang bis Ende
            For lngTMP = LBound(strTrenn) To UBound(strTrenn)
                ' Wenn das Wort Rechnung gefunden wird...
                If strTrenn(lngTMP) Like "*Rechn*" Then
                    ' ... schreibe den nächsten Wert in Variable strTMP
                    strTMP = Trim(strTrenn(lngTMP + 1))
                ' Oder wenn das Wort Kunde gefunden wird...
                ElseIf strTrenn(lngTMP) Like "*Kund*" Then
                    ' ... schreibe den nächsten Wert in Variable strTMP1
                    strTMP1 = Trim(strTrenn(lngTMP + 1))
                End If
            Next lngTMP
            ' Word- Pdf-Dokument ohne speichern schlissen
            objDocument.Close False
            ' Datei umbenennen mit Datum und Zeit am Ende
            Name strDir & strDatei As strDir & strTMP & "_" & strTMP1 & _
                Format(Now, "_DD_MM_YYYY_hh_mm_ss") & ".pdf"
            ' Array und Variablen leeren
            Erase strTrenn
            strTMP1 = ""
            strTMP = ""
            ' Die nächste Datei nehmen
            strDatei = Dir$()
            Set objDocument = Nothing
        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
    ' Objektvariablen leeren
    Set objDocument = Nothing
    Set objApp = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        Application.ReferenceStyle = lngRef
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : OffApp
' Author    : Case (Ralf Stolzenburg)
' Date      : 20.05.2019
' Purpose   : Start Applikation...
'--------------------------------------------------------------------------
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

Spielerei mit Formeln - Ausgabe der Berechnungsschritte...

Spielerei mit Formeln. Eingegebene Berechnungen ausrechnen. Entweder in der gleichen Zelle, oder rechts daneben. Play with formulas. Calcu...