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

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 ...