11.12.2013

Daten nach Spalte B in neue Dateien aufteilen - Spezialfilter...

Frage: Daten sind in Spalte B. Alle unterschiedlichen Einträge sollen als separate Datei gespeichert werden. Die Daten sind in den Spalten A bis E und es gibt eine Überschrift. Diese soll auch in alle Dateien. Zusätzlich sollen noch Summen ausgerechnet werden. Der Name der Datei ist "irgendeinText" plus den Tabellenblattnamen. Wie geht das?

Data are in column B. All the different entries are to be stored as a separate file. The data is in columns A to E and there is a headline. This is also in all the files. In addition, still sums to be calculated. The name of the file is "some text" plus the worksheet name. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Daten nach Spalte B in neue Dateien aufteilen - Spezialfilter...[XLS 50 KB]

Link für FileFormat / Link for FileFormat:
FileFormat

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 11.12.2013
' Purpose   : Daten Spalte B jeweils in neue Dateien aufteilen - Summe...
'--------------------------------------------------------------------------
Sub Main()
    ' Variablendeklaration
    Dim wksKriterienSheet As Worksheet
    Dim wksQuellSheet As Worksheet
    Dim rngKriterium As Range
    Dim wksNew As Worksheet
    Dim wkbBook As Workbook
    Dim lngLastTMP As Long
    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
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Tabellenblatt mit Daten - Name ANPASSEN!!!
    Set wksQuellSheet = Worksheets("Total")
    ' Neues Tabellenblatt für die Kriterien
    ' Man könnte es auch ohne dieses zusätzliche Sheet machen
    Set wksKriterienSheet = Worksheets.Add
    ' Tabellenblatt verschieben - muss man nicht - kann man :-)
    wksKriterienSheet.Move After:= _
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ' Letzte Zeile der Spalte B im Quellsheet ermitteln
    With wksQuellSheet
        lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
            .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
    End With
    ' Spezialfilter - Spalte B ohne Doppelte ins neue Tabellenblatt
    wksQuellSheet.Range("B1:B" & lngLastRow).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
    ' Erstes Kriterium nehmen
    Set rngKriterium = wksKriterienSheet.Range("A2")
    ' Schleife bis alle Kriterien abgearbeitet sind
    While rngKriterium.Value <> ""
        ' Temporäres Tabellenblatt - nimmt die Daten auf
        Set wksNew = Worksheets.Add
        ' Spezialfilter nach Kriterium in neues Tabellenblatt
        wksQuellSheet.Range("A1:E" & lngLastRow).AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
            CopyToRange:=wksNew.Range("A1"), Unique:=True
        ' Tabellenblatt umbenennen nach Kriterium
        wksNew.Name = rngKriterium.Text
        ' Erledigtes Kriterium löschen
        rngKriterium.EntireRow.Delete
        ' Fertiges Tabellenblatt in neue Datei kopieren
        wksNew.Copy
        Set wkbBook = ActiveWorkbook
        ' Summen- und Berechnungsformel eintragen
        With wkbBook.Worksheets(1)
            lngLastTMP = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            .Cells(lngLastTMP + 1, 3).Formula = "=Sum(C2:C" & lngLastTMP & ")"
            .Cells(lngLastTMP + 1, 5).Formula = "=Sum(E2:E" & lngLastTMP & ")"
            .Cells(lngLastTMP + 2, 5).Formula = "=(C" & lngLastTMP + 1 & _
                "-E" & lngLastTMP + 1 & ")*3"
            ' Bei Minusbeträgen wird es rot - Tausenderpunk setzen
            .Cells(lngLastTMP + 2, 5).NumberFormat = "#,##0.00;[Red]#,##0.00"
            ' Optimale Breite der Spalten
            .Columns("A:E").AutoFit
        End With
        ' Wenn die Applikation < Excel 2007 ist dann...
        If Val(Application.Version) < 12 Then
            wkbBook.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & "Number_" & wksNew.Name & ".xls"
        ' Sonst muss das FileFormat angegeben werden!!!
        ' Siehe folgenden Blogeintrag
        ' http://vbanet.blogspot.de/2012/07/datei-speichern-dialog-format.html
        Else
            wkbBook.SaveAs ThisWorkbook.Path & _
                Application.PathSeparator & "Number_" & wksNew.Name, 56
        End If
        ' Datei schliessen ohne zu speichern
        wkbBook.Close SaveChanges:=False
        ' Setze die Objektvariable auf Nothing
        Set wkbBook = Nothing
        ' Temporäres Tabellenblatt löschen
        wksNew.Delete
        ' Setze die Objektvariablen auf Nothing
        Set wksNew = Nothing
        Set rngKriterium = Nothing
        ' Das nächste Kriterium
        Set rngKriterium = wksKriterienSheet.Range("A2")
    ' Schleife
    Wend
    ' Kriteriumstabellenblatt löschen
    wksKriterienSheet.Delete
    ' Setze die Objektvariable auf Nothing
    Set wksKriterienSheet = Nothing
Fin:
    ' Bei Bedarf temporäre Tabellenblätter/Datei löschen/schliessen
    If Not wkbBook Is Nothing Then wkbBook.Close SaveChanges:=False
    If Not wksNew Is Nothing Then wksNew.Delete
    If Not wksKriterienSheet Is Nothing Then wksKriterienSheet.Delete
    ' Setze die Objektvariablen auf Nothing
    Set wkbBook = Nothing
    Set wksKriterienSheet = Nothing
    Set wksQuellSheet = Nothing
    Set rngKriterium = Nothing
    Set wksNew = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .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

28.11.2013

Zusätzlich beim speichern ein Tabellenblatt als PDF ablegen...

Frage: Ein bestimmtes Tabellenblatt soll zusätzlich zum speichern der Excel Datei noch als PDF gespeichert werden. Eine vorhandene PDF-Datei soll ohne Nachfrage überschrieben werden. Wie geht das?

One particular worksheet is in addition to save the Excel file be saved as a PDF. An existing PDF file will be overwritten without prompting. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Zusätzlich beim speichern ein Tabellenblatt als PDF ablegen...[ZIP 80 KB]

Code gehört in "DieseArbeitsmappe" / Code belongs in "ThisWorkbook":

Option Explicit
Private Declare Function MakeSureDirectoryPathExists _
    Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" _
    Alias "PathFileExistsA" (ByVal pszPath As String) As Long
' Pfad für die PDF-Datei MIT abschliessendem Backslash anpassen!!!!
Const strPDFPath As String = "C:\Temp\"
'--------------------------------------------------------------------------
' Module    : ThisWorkbook
' Procedure : Workbook_BeforeSave
' Author    : Case (Ralf Stolzenburg)
' Date      : 28.11.2013
' Purpose   : Always save as PDF in particular folder...
'--------------------------------------------------------------------------
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    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
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Name des Tabellenblattes anpassen!!!!!
    With ThisWorkbook.Worksheets("Sheet1")
        ' Prüfen ob Ordner vorhanden ist
        If PathFileExists(strPDFPath) <> 0 Then
            ' PDF-Datei im vorgegebenen Pfad erstellen - NUR ein Tabellenblatt
            ' Dateiname ist wie Exceldateiname mit Datum und Uhrzeit
            '.ExportAsFixedFormat 0, strPDFPath & fncEXT(.Parent.Name) & _
                Format(Now, "_YYYY_MM_DD_hh_mm_ss")
            ' Dateiname ist wie Exceldateiname VORHANDENE DATEI WIRD ERSETZT
            .ExportAsFixedFormat 0, strPDFPath & fncEXT(.Parent.Name)
            ' PDF-Datei im vorgegebenen Pfad erstellen - NUR ein Tabellenblatt
            ' Dateiname ist wie Worksheetname mit Datum und Uhrzeit
            '.ExportAsFixedFormat 0, strPDFPath & .Name & _
                Format(Now, "_YYYY_MM_DD_hh_mm_ss")
            ' Dateiname ist wie Worksheetname VORHANDENE DATEI WIRD ERSETZT
            '.ExportAsFixedFormat 0, strPDFPath & .Name
        Else
            ' Pfad anlegen
            MakeSureDirectoryPathExists (strPDFPath)
            ' PDF-Datei im vorgegebenen Pfad erstellen
            .ExportAsFixedFormat 0, strPDFPath & fncEXT(.Parent.Name) & _
                Format(Now, "_YYYY_MM_DD_hh_mm_ss")
        End If
        Application.Run ("Module1.Main")
    End With
Fin:
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .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
' Name und Extension trennen
Function fncEXT(ByVal strName As String) As String
    fncEXT = Mid(strName, 1, InStr(strName, ".") - 1)
End Function

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

Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 28.11.2013
' Purpose   : Ausblenden Druckvorschaulinien. Hide print preview lines...
'--------------------------------------------------------------------------
Private Sub Main()
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        ' Die Druckvorschaulinien ausblenden
        wksSheet.DisplayAutomaticPageBreaks = False
    Next wksSheet
End Sub

22.11.2013

PDF-Dateien öffnen - auch wenn in Unterordner...

Frage: In einem Tabellenblatt habe ich in einer Spalte Nummern stehen. Es befinden sich im gleichen Ordner wie die Exceldatei PDF-Dateien. PDF-Dateien können aber auch noch in einem Unterordner sein. Diese PDF-Dateien haben den gleichen Namen wie die Nummern in Excel. Wie kann ich die PDF-Dateien öffnen?

In a worksheet I have in a column numbers. There are in the same folder as the Excel file PDF files. But PDF files can also be in a subfolder. These PDF files have the same name as the numbers in Excel. How can I open the PDF files?

Hier noch eine Beispieldatei / Here's a sample file:
PDF-Dateien öffnen - auch wenn in Unterordner...[ZIP 800 KB]

Option Explicit
' Bedingte Kompilierung - wenn 64 Bit dann...
#If Win64 Then
    Private Declare PtrSafe Function SearchTreeForFile Lib "imagehlp.dll" _
        (ByVal RootPath As String, ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long
' ... sonst...
#Else
    Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
        (ByVal RootPath As String, ByVal InputPathName As String, _
        ByVal OutputPathBuffer As String) As Long
#End If
' Bedingte Kompilierung - wenn 64 Bit dann...
#If Win64 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, _
        ByVal nShowCmd As Long) As Long
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
        ByVal lpParameters As String, ByVal lpDirectory As String, _
        ByVal nShowCmd As Long) As Long
#End If
Private Const SW_MAXIMIZE = 3
' Dateierweiterung gegebenenfalls anpassen!!!
Const strEX As String = ".pdf"
'--------------------------------------------------------------------------
' Module    : Sheet1
' Procedure : BeforeDoubleClick
' Author    : Case (Ralf Stolzenburg)
' Date      : 22.11.2013
' Purpose   : Open PDF files - even if in subfolder...
'--------------------------------------------------------------------------
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' Variablendeklaration
    ' Stringvariable mit Puffer
    Dim strPathName As String * 255
    Dim strName As String
    Dim lngTMP As Long
    On Error GoTo Fin
    ' Einschränkung auf Spalte 3 = C
    If Not Intersect(Target, Columns(3)) Is Nothing Then
        ' Nach Doppelklick auf Zelle NICHT in den Bearbeitungsmodus wechseln
        Cancel = True
        ' Datei suchen, wenn gefunden ist der Rückgabewert ein Long ungleich 0
        lngTMP = SearchTreeForFile(ThisWorkbook.Path & _
            Application.PathSeparator, Target.Text & _
            strEX, strPathName)
        If lngTMP = 0 Then
            ' Datei nicht vorhanden!
            MsgBox "File not found!"
        Else
            ' Puffer zurechtstutzen, überflüssige Leerzeichen weg
            strPathName = Left$(strPathName, InStr(1, strPathName, vbNullChar) - 1)
            strName = RTrim(strPathName)
            ' Datei öffnen
            ShellExecute 0, "Open", strName, "", "", SW_MAXIMIZE
        End If
    End If
Fin:
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

29.10.2013

Geschlossene Dateien - drei und mehrere Zellen (Array) auslesen...

Frage: Aus allen Dateien eines Ordners (optional mit Unterordner) werden drei Zellen per Formelverweis ausgelesen. Die Werte sollen in Spalte A (C5), Spalte B (G7) und Spalte C (J12) eingefügt werden. Es können aber auch mehr Zellen werden. Wie geht das? (Bei mehr als 2 bis 3 Zellen nutzen wir ein Array mit Schleife - siehe zweiten Code).

From all files in a folder (optionally with subfolders) three cells are read using a formula reference. The values ​​to be inserted in column A, column B and column C. But it may also be more cells. How does it work? (With more than 2 to 3 cells, we use an array with loop - see second code).

Hier noch eine Beispieldatei / Here's a sample file:
Geschlossene Dateien - drei und mehrere Zellen (Array) auslesen...[ZIP 80 KB]

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Werte"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Tabelle1"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C5"
' Die Zelle wird ausgelesen
Const strCellQ2 As String = "G7"
' Die Zelle wird ausgelesen
Const strCellQ3 As String = "J12"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.10.2013
' Purpose   : Geschlossene Dateien - drei Zellen auslesen...
'--------------------------------------------------------------------------
Public Sub Files_Read()
    ' Variablendeklaration
    Dim blnUpdate As Boolean
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir 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
        .ScreenUpdating = False
        blnUpdate = .AskToUpdateLinks
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Bei Bedarf!!!!!!
    ' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
    With ThisWorkbook.Worksheets(strSheetZ)
        .Rows("2:" & .Rows.Count).ClearContents
    End With
    ' Der Objektvariablen objFSO das "FilesystemObject" zuweisen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien
    strDir = ThisWorkbook.Path
    'strDir = "C:\Temp\Los\"  ' Fester Pfad
    Set objDir = objFSO.GetFolder(strDir)
    ' Mit Unterordner
    dirInfo objDir, "*.xls*", True
    ' Ohne Unterordner
    'dirInfo objDir, "*.xls*"
Fin:
    ' Setze die Objektvariablen auf Nothing
    Set objDir = Nothing
    Set objFSO = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = blnUpdate
        .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 "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : dirInfo
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.10.2013
' Purpose   : Geschlossene Dateien - drei Zellen auslesen...
'--------------------------------------------------------------------------
' Rekursive Sub - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    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
        If varTMP.Name Like strName And varTMP.Name <> ThisWorkbook.Name Then
            ' Prüfe, ob es eine temporäre Datei ist
            If 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 A plus 1
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                        .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                    ' Verschachteltes "With"
                    With .Cells(lngLastRow, 1)
                        ' Werte über Formel holen, Tabellenblatt und Zelle
                        ' Über "Const..." oben definiert. Schreiben in Spalte A
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ1
                        ' Formel entfernen - Wert bleibt erhalten
                        .Value = .Value
                        ' Hier würde jetzt noch der Dateiname in Spalte D geschrieben
                        '.Offset(0, 3).Value = varTMP.Name
                        ' Hier würde jetzt noch der Dateiname mit Pfad in Spalte D geschrieben
                        '.Offset(0, 3).Value = varTMP.Path
                    End With
                    ' Verschachteltes "With"
                    With .Cells(lngLastRow, 2)
                        ' Werte über Formel holen, Tabellenblatt und Zelle
                        ' Über "Const..." oben definiert. Schreiben in Spalte B
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ2
                        ' Formel entfernen - Wert bleibt erhalten
                        .Value = .Value
                    End With
                    ' Verschachteltes "With"
                    With .Cells(lngLastRow, 3)
                        ' Werte über Formel holen, Tabellenblatt und Zelle
                        ' Über "Const..." oben definiert. Schreiben in Spalte B
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, "\") + 1) & "]" & _
                            strSheetQ & "'!" & strCellQ3
                        ' Formel entfernen - Wert bleibt erhalten
                        .Value = .Value
                    End With
                End With
            End If
        End If
    Next
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read" vorgegeben
    ' Dann durchsuche auch alle Unterordner
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
End Sub

Zweites Beispiel bei mehreren Zellen - Array / Second example with multiple cells - array.

' Variablendeklaration erforderlich
Option Explicit
' Der Tabellenblattname in den auszulesenden Dateien
Const strSheetQ As String = "Werte"
' Der Tabellenblattname in DIESER Datei (die mit dem Code)
Const strSheetZ As String = "Tabelle1"
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : Files_Read_1
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.10.2013
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen...
'--------------------------------------------------------------------------
Public Sub Files_Read_1()
    ' Variablendeklaration
    Dim blnUpdate As Boolean
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir 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
        .ScreenUpdating = False
        blnUpdate = .AskToUpdateLinks
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .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
    'strDir = "C:\Temp\Los\"  ' Fester Pfad
    Set objDir = objFSO.GetFolder(strDir)
    ' 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)
        ' Inhalt von Tabelle "strSheetZ" wird ab Zeile 2 gelöscht
        .Rows("2:" & .Rows.Count).ClearContents
        ' Mit Unterordner
        dirInfo objDir, "*.xls*", True
        ' Ohne Unterordner
        'dirInfo objDir, "*.xls*"
        ' Formeln entfernen - Werte bleiben erhalten
        .UsedRange.Value = .UsedRange.Value
    End With
Fin:
    ' Setze die Objektvariablen auf Nothing
    Set objDir = Nothing
    Set objFSO = Nothing
    ' Die Applikation aufwecken
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = blnUpdate
        .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 "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Modul1
' Procedure : dirInfo
' Author    : Case (Ralf Stolzenburg)
' Date      : 29.10.2013
' Purpose   : Geschlossene Dateien - mehrere Zellen auslesen...
'--------------------------------------------------------------------------
' Rekursive Sub mit Array - Optional mit Unterordner
Public Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
    Optional ByVal blnTMP As Boolean = False)
    ' Variablendeklaration
    Dim strFormula As String
    Dim lngLastRow As Long
    Dim arrCell As Variant
    Dim intTMP As Integer
    Dim varTMP As Variant
    ' Weitere Zellen nach gleichem Muster in das Array einfügen
    arrCell = Array("A2", "A9", "B3", "B11", "C5", "D9", "G7", "J12")
    ' 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
        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 A plus 1
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 1)), _
                    .Rows.Count, .Cells(.Rows.Count, 1).End(xlUp).Row) + 1
                ' Schleife über alle Zellen des Arrays
                For intTMP = LBound(arrCell) To UBound(arrCell)
                    ' Hier würde jetzt noch der Dateiname mit Pfad
                    ' in die nächste freie Spalte geschrieben
                    '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Path
                    ' Hier würde jetzt noch der Dateiname
                    ' in die nächste freie Spalte geschrieben
                    '.Cells(lngLastRow, UBound(arrCell) + 2).Value = varTMP.Name
                    ' Werte über Formel holen, Tabellenblatt über "Const..."
                    ' oben definiert, Zelle über Array. Formel in Spalte A folgende...
                    .Cells(lngLastRow, intTMP + 1).Formula = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & strSheetQ & "'!" & arrCell(intTMP)
                Next intTMP
            End With
        End If
    Next varTMP
    ' Wenn die Variable blnTMP "True" ist (in der Sub "Files_Read_1" vorgegeben
    ' Dann durchsuche auch alle Unterordner
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
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 ...