14.07.2014

Word öffnen, Range formatiert kopieren, nicht als Tabelle...

Einen Range (z. B. A1:A10) nach Word kopieren. Schriftformate unverändert übernehmen. Es darf aber nicht als Tabelle eingefügt werden bzw. muss als Text umgewandelt werden.

A range (eg A1:A10) copy to Word. Font formats take over unchanged. But it must not be inserted as a table or must be converted as text.

Hier noch eine Beispieldatei / Here's a sample file:
Word öffnen, Range formatiert kopieren, nicht als Tabelle...[ZIP 20 KB]

Option Explicit
' Konstante für Parameter Umwandlung der Tabelle in Word als Text
' Es gibt:
' Const wdSeparateByDefaultListSeparator = 3
' Const wdSeparateByCommas = 2
' Const wdSeparateByTabs = 1
Const wdSeparateByParagraphs = 0
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 14.07.2014
' Purpose   : Word öffnen, Range formatiert kopieren, nicht als Tabelle...
'--------------------------------------------------------------------------
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
            Tabelle1.Range("A1:A10").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
            ' Umwandlen der Tabelle zu Text
            objWDDoc.Tables(1).Rows.ConvertToText Separator:=wdSeparateByParagraphs, _
                NestedTables:=True
        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      : 14.07.2014
' 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.04.2014

Geschlossene Dateien - Range in Masterdatei in Zeilen auslesen...

Frage: Bestimmte Daten (B2:C2, B3:C3, B4:C4) aus über 200 Exceldateien in eine Masterdatei in A2 abwärts. Der Dateiname in Spalte A, der Rest in die Spalten B:G. Wie geht das?

Certain data (B2:C2, B3:C3, B4:C4) from over 200 Excel files into a master file in A2 down. The file name in column A and the rest in columns B:G. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - Range in Masterdatei in Zeilen auslesen...[ZIP 300 KB]

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Tabelle1"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Total"
' Dieser Bereich wird ausgelesen
Const strRange1 As String = "B2:C2"
Const strRange2 As String = "B3:C3"
Const strRange3 As String = "B4:C4"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 24.04.2014
' Purpose   : Geschlossene Dateien Range auslesen...
'--------------------------------------------------------------------------
Public Sub Main()
    Dim stCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt - UNBEDINGT wieder einschalten
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien
     strDir = ThisWorkbook.Path & Application.PathSeparator
    ' Fester Ordner vorgegeben
    'strDir = "C:\Temp\Test\"
    strDir = IIf(Right(strDir, 1) <> "\", strDir & "\", strDir)
    Set objDir = objFSO.GetFolder(strDir)
    ' Der Code bezieht sich auf ein bestimmtes Objekt
    ' Hier das Objekt (bzw. die Variable) strSheetZ
    ' Alles was sich auf dieses "With" bezieht
    ' MUSS mit einem Punkt beginnen
    With ThisWorkbook.Worksheets(strSheetZ)
        .Rows("2:" & .Rows.Count).ClearContents
        'dirInfo objDir, "*.xls*", True ' Mit Unterordner
        dirInfo objDir, "*.xls*" ' Ohne Unterordner
        ' Formeln entfernen - Werte bleiben erhalten
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        .Goto (ThisWorkbook.Worksheets(strSheetZ).Range("A1")), True
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    ' Setze die Objektvariablen auf Nothing
    Set objDir = Nothing
    Set objFSO = 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    : Modul1
' Procedure : dirInfo
' Author    : Case (Ralf Stolzenburg)
' Date      : 24.04.2014
' Purpose   : Geschlossene Dateien - Range auslesen...
'--------------------------------------------------------------------------
' Rekursive Sub - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    Dim objWorkbook As Workbook
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim varTMP As Variant
    ' Alle Dateien im vorgegebenen Ordner
    For Each varTMP In objCurrentDir.Files
        ' Dateiname entspricht den Vorgaben und ist nicht DIESE Datei
        ' Falls im gleichen Ordner und ist KEINE temporäre Datei
        ' Dafür die Abfrage nach der Tilde "~"
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name And Left(varTMP.Name, 1) <> "~" Then
            ' Der Code bezieht sich auf ein bestimmtes Objekt
            ' Hier strSheetZ
            ' Alles was sich auf dieses "With" bezieht
            ' MUSS mit einem Punkt beginnen
            With ThisWorkbook.Worksheets(strSheetZ)
                ' Letzte Zeile bezogen auf Spalte B plus 1
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
                    .Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
                ' Dateiname mit Pfadangabe
                '.Cells(lngLastRow, 1).Value = varTMP.Path
                ' Hier nur Dateiname ohne Pfadangabe
                .Cells(lngLastRow, 1).Value = varTMP.Name
                ' Werte über Formel holen, Tabellenblatt über "Const..."
                ' oben definiert, Range auch oben definiert.
                ' Formel in Spalte B:G. Datumsformat setzen
                With .Range(.Cells(lngLastRow, 2), .Cells(lngLastRow, 3))
                    .NumberFormat = "m/d/yyyy"
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange1
                End With
                With .Range(.Cells(lngLastRow, 4), .Cells(lngLastRow, 5))
                    .NumberFormat = "m/d/yyyy"
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange2
                End With
                With .Range(.Cells(lngLastRow, 6), .Cells(lngLastRow, 7))
                    .NumberFormat = "m/d/yyyy"
                    .FormulaArray = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ & "'!" & strRange3
                End With
            End With
        End If
    Next varTMP
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Main" vorgegeben)
    ' Dann durchsuche auch alle Unterordner
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
    ' Setze die Objektvariable auf Nothing
    Set objWorkbook = Nothing
End Sub

09.04.2014

Outlook - neueste Mail mit bestimmtem Betreff - Informationen ausgeben...

Frage: Im Ordner Posteingang sind mehrere Mails mit dem gleichen Betreff. Von diesen Mails benötige ich die Neueste. Im folgenden Beispiel wird die Mailadresse und der Name des Absenders angezeigt. Zusätzlich noch die Empfangszeit der Mail.

In the Inbox folder are several emails with the same subject. Of these mails I need the latest. In the following example, the email address and the name of the sender is displayed. In addition the time of receipt of mail.

Hier noch eine Beispieldatei / Here's a sample file:
Outlook - neueste Mail mit bestimmtem Betreff - Informationen ausgeben...[XLS 50 KB]

Option Explicit
' Variable um bei schon geöffnetem Outlook dieses nicht zu schliessen
Dim blnTMP As Boolean
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 09.04.2014
' Purpose   : Outlook Subject mehrere gleiche neueste Infos ausgeben...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim objNameSpace As Object
    Dim objFolder As Object
    Dim objItem As Object
    Dim strTMP As String
    Dim objApp As Object
    Dim datTime As Date
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Objektvariable mit Outlookapplikation belegen
    Set objApp = OffApp("Outlook")
    ' Wenn die Applikation vorhanden ist...
    If Not objApp Is Nothing Then
        ' Eine Outlook-Sitzung anlegen
        ' GetNamespace("MAPI") und Session sind austauschbar
        Set objNameSpace = objApp.Session 'GetNamespace("MAPI")
        ' Konstante für Posteingang
        Const olFolderInbox = 6
        ' Objektvariable mit Posteingang belegen
        Set objFolder = objNameSpace.GetDefaultFolder(olFolderInbox)
        ' Wenn Mails im Posteingang sind, dann...
        If objFolder.Items.Count > 0 Then
            ' Temporäre Zeit vorgeben
            datTime = "01.01.1900 00:00:00"
            ' Jede Mail im Ordner Posteingang durchgehen
            For Each objItem In objFolder.Items
                With objItem
                    ' Wenn der Betreff mit "Test" beginnt und
                    ' irgendwie weitergeht, dann...
                    If .Subject Like "Test*" Then
                        ' Wenn die Empfangszeit > der
                        ' temporären Zeit ist, dann...
                        If .ReceivedTime > datTime Then
                            ' Setze die temporäre Zeit neu
                            datTime = .ReceivedTime
                            ' Hole Informationen in Stringvariable
                            ' Hier Mailadresse und Name des Senders
                            ' dann noch die Empfangszeit
                            strTMP = .SenderEmailAddress & " / " & _
                                .SenderName & " / " & .ReceivedTime
                        End If
                    End If
                End With
            ' Nächste Mail
            Next objItem
            ' Wenn die temporäre Zeit unterschiedlich ist, dann...
            If datTime <> "01.01.1900 00:00:00" Then
                ' Gib die gesammelten Informationen aus
                MsgBox strTMP
            End If
        Else
            ' Es sind keine Mails im Posteingang
            MsgBox "There are " & objFolder.Items.Count & " message(s) in your inbox."
        End If
    Else
        ' Kein Outlook installiert
        MsgBox "Application not installed!"
    End If
Fin:
    ' Wenn die Applikation nicht offen war, schliesse sie
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    ' Setze die Objektvariablen auf Nothing
    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set objApp = 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
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

21.01.2014

Daten Spalte C nach Monat in neue Tabellenblätter aufteilen - Spezialfilter...

Frage: Alle Buchungen aus dem Jahre 2013 befinden sich auf einem Tabellenblatt. Das Datum steht in Spalte C. Die Daten müssen in neue Tabellenblätter aufgeteilt werden. Die Daten müssen nach Monat kopiert werden. Wie geht das?

All bookings from the year 2013 are on a worksheet. The date is in column C. The data must be divided into new worksheets. The data must be copied by month. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Daten Spalte C nach Monat in neue Tabellenblätter aufteilen - Spezialfilter...[XLS 250 KB]

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 21.01.2014
' Purpose   : Daten Spalte C Datum - Monat in Tabellenblätter aufteilen...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variablendeklaration
    Dim CriteriaSheet As Worksheet
    Dim SourceSheet As Worksheet
    Dim rngCriterion As Range
    Dim wksNew As Worksheet
    Dim wksTMP As Worksheet
    Dim lngLastRow As Long
    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
    ' Schleife über jeder Tabellenblatt in dieser Datei
    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
    ' Tabellenblatt mit den Grunddaten - Name ANPASSEN
    Set SourceSheet = Worksheets("2013")
    ' Ein Kriterientabellenblatt wird hinzugefügt
    Set CriteriaSheet = Worksheets.Add
    ' Und an das Ende verschoben
    CriteriaSheet.Move After:= _
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ' Ermittelt die letzte belegte Zeile im Quelltabellenblatt Splate C
    lngLastRow = SourceSheet.Range("C" & Rows.Count).End(xlUp).Row
    ' Füge eine Hilfsspalte im Quelltabellenblatt vor Spalte A ein
    SourceSheet.Range("A1").EntireColumn.Insert
    ' Setzt eine Überschrift
    SourceSheet.Range("A1").Value = "TEMP"
    ' Per Formel die Monatszahl in jede Zelle schreiben
    SourceSheet.Range("A2:A" & lngLastRow).Formula = "=Month(D2)"
    ' Dann die Kriterien ohne Doppelte ins Lriterientabellenblatt kopieren
    SourceSheet.Range("A1:A" & lngLastRow).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=CriteriaSheet.Range("A1"), Unique:=True
    ' Das erste Kriterium zuweisen
    Set rngCriterion = CriteriaSheet.Range("A2")
    ' So lange schleifen, bis kein Kriterium mehr vorhanden ist
    While rngCriterion.Value <> ""
        ' Neues Tabellenblatt
        Set wksNew = Worksheets.Add
        ' Ans Ende stellen
        wksNew.Move After:= _
            ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ' Über Spezialfilter den jeweiligen Monat kopieren
        SourceSheet.Range("A1:H" & lngLastRow).AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngCriterion.Offset(-1).Resize(2), _
            CopyToRange:=wksNew.Range("A1")
        ' Tabellenblatt mit Monatsnamen benennen
        wksNew.Name = Format(wksNew.Range("D2").Value, "MMMM")
        ' Die temporäre erste Spalte löschen
        wksNew.Columns("A").Delete
        ' Das erledigte Kriterium löschen
        rngCriterion.EntireRow.Delete
        ' Setze die Objektvariablen auf Nothing
        Set rngCriterion = Nothing
        Set wksNew = Nothing
        ' Das nächste Kriterium zuweisen
        Set rngCriterion = CriteriaSheet.Range("A2")
    Wend
    ' Die temporäre Spalte auch im Quelltabellenblatt löschen
    SourceSheet.Columns("A").Delete
    ' Wenn ein Kriterientabellenblatt vorhanden ist, lösche es
    If Not CriteriaSheet Is Nothing Then CriteriaSheet.Delete
Fin:
    ' Die Applikation aufwecken
    With Application
        ' Gehe zum Quelltabellenblatt nach A1
        .Goto SourceSheet.Range("A1"), True
        ' 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
    ' Setze die Objektvariablen auf Nothing
    Set CriteriaSheet = Nothing
    Set SourceSheet = Nothing
    Set rngCriterion = Nothing
    Set wksNew = 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

Word - Kontrollkästchen (Formularsteuerelement) auslesen...

Aus allen Worddateien sollen die Kontrollkästchen (Formularsteuerelement) ausgelesen werden - Haken gesetzt oder nicht. Auch ein Textfeld (F...