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

25.10.2013

Benannte Bereiche - Named Ranges - die 2te...

Frage: Noch einmal eine Frage zu benannten Bereichen. Wenn in Spalte D ein Name eingegeben wird, soll ein benannter Bereich erstellt werden mit dem Bereich Spalt E bis Spalte M der jeweiligen Zeile. Wird der Eintrag in Spalte D gelöscht, soll auch der benannte Bereich gelöscht werden. Wie geht das?

Once again about named ranges. If a name is entered in column D, is a named range are created using the gap area E to the M column of the respective row. If the entry is deleted in column D, also the named range to be deleted. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Benannte Bereiche - Named Ranges - die 2te...[ZIP 20 KB]

Code gehört in DieseArbeitsmappe / Code is in ThisWorkbook.
Option Explicit
Private Sub Workbook_Open()
    If ActiveCell.Column = 4 Then
        If ActiveCell.Value <> "" Then
            strOldName = ActiveCell.Value
        End If
    End If
End Sub

Code gehört in ein allgemeines Modul / Code belongs in a general module.
Option Explicit
Public strOldName As String

Code gehört in das Klassenmodul des Tabellenblattes / Code belongs to the class module of the worksheet.
Option Explicit
'--------------------------------------------------------------------------
' Module    : Sheet1
' Procedure : Worksheet_Change
' Author    : Case (Ralf Stolzenburg)
' Date      : 25.10.2013
' Purpose   : Create/Delete named ranges - entries in column D...
'--------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fin:
    #If VBA7 Then
        If Not Target.CountLarge > 1 Then
    #Else
        If Not Target.Count > 1 Then
    #End If
        Application.EnableEvents = False
        If Not Target.Column <> 4 Then
            If Trim(Target.Value) <> "" Then
                ThisWorkbook.Names.Add Name:=Target.Value, _
                    RefersToR1C1:="=" & _
                    Me.Name & "!" & "R" & Target.Row & "C" & _
                    Target.Column + 1 & ":" & "R" & _
                    Target.Row & "C" & Target.Column + 9
            Else
                ThisWorkbook.Names(strOldName).Delete
            End If
        End If
    End If
Fin:
    Application.EnableEvents = True
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'--------------------------------------------------------------------------
' Module    : Sheet1
' Procedure : Worksheet_SelectionChange
' Author    : Case (Ralf Stolzenburg)
' Date      : 25.10.2013
' Purpose   : Create/Delete named ranges - entries in column D...
'--------------------------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    #If VBA7 Then
       If Not Target.CountLarge > 1 Then
    #Else
        If Not Target.Count > 1 Then
    #End If
        strOldName = Target.Value
    End If
End Sub

24.10.2013

Hyperlink in Spalte A ausführen bei Klick auf Spalte E...

Frage: Meine Hyperlinks sind in Spalte A. Diese möchte ich bei einem Klick auf Spalte E ausführen. Dies unabhängig davon ob es eingefügte Hyperlinks sind oder über die Hyperlink-Funktion. Wie geht das?

My Hyperlinks are in column A. I want to run this at a click of column E. This is regardless of whether they are inserted hyperlinks or the hyperlink function. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Hyperlink in Spalte A ausführen bei Klick auf Spalte E...[ZIP 450 KB]

' Variablendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : Sheet1
' Procedure : Worksheet_SelectionChange
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.10.2013
' Purpose   : Hyperlink in Spalte A ausführen bei Klick auf Spalte E...
'--------------------------------------------------------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke
    On Error GoTo Fin
    ' Ereignisroutinen werden deaktiviert
    Application.EnableEvents = False
    ' Bedingte Kompilierung - siehe folgende Links...
    ' http://msdn.microsoft.com/de-de/library/office/gg264803.aspx
    ' http://msdn.microsoft.com/de-de/library/office/ee691831%28v=office.14%29.aspx
    #If VBA7 Then
        If Not Target.CountLarge > 1 Then
    #Else
        If Not Target.Count > 1 Then
    #End If
        ' Wenn in Spalte E geklickt wird, dann...
        If Not Intersect(Target, Columns(5)) Is Nothing Then
            ' Code bezieht sich auf entsprechende Zelle in Spalte A
            With Target.Offset(, -4)
                ' Wenn dort ein Hyperlink ist dann...
                If .Hyperlinks.Count = 1 Then
                    ' ... öffne den Link
                    ThisWorkbook.FollowHyperlink .Hyperlinks(1).Address
                ' Wenn dort eine Formel (=HYPERLINK) ist, dann...
                ElseIf .Formula Like "=HYPER*" Then
                    ' öffne den Hyperlink (gesplittet aus der Formel)
                    ThisWorkbook.FollowHyperlink Split(.Formula, """")(1)
                End If
            End With
        End If
    End If
Fin:
    ' Ereignisroutinen werden aktiviert
    Application.EnableEvents = True
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

23.10.2013

Benannte Bereiche - Named Ranges...

Frage: In Spalte D stehen verschiedene Einträge (z. B. Buch, Magazin...). Für alle unterschiedlichen Einträge benötige ich einen benannten Bereich bezogen auf Spalte E. Wie geht das?

In column D different entries (eg book, magazine ...). For all the different items I need a named range relative to column E. How does it work?

Hier noch eine Beispieldatei / Here's a sample file:
Benannte Bereiche - Named Ranges...[XLS 40 KB]

' Require Variable Declaration
Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.10.2013
' Purpose   : Create named ranges - different entries in column D...
'--------------------------------------------------------------------------
Public Sub Main()
    ' Variable Declaration
    Dim rngUnion As Range
    Dim lngRow As Long
    On Error GoTo Fin
    ' This macro is invoked only for testing - the call can later be deleted
    Call Main_1
    ' All objects related to Sheet1 - MUST begin with a dot
    With Sheet1
        ' Determine the last occupied cell in column D
        lngRow = IIf(IsEmpty(.Cells(.Rows.Count, 4)), _
            .Cells(.Rows.Count, 4).End(xlUp).Row, .Rows.Count)
        ' Loop from row 2 to the last row
        For lngRow = 2 To lngRow
            ' If the entry in the cell is equal to
            ' the entry in the next cell, then ...
            If .Cells(lngRow, 4).Value <> .Cells(lngRow + 1, 4).Value Then
                ' If the object variable "rngUnion" is not yet occupied, then...
                If Not rngUnion Is Nothing Then
                    ' Set the object variable "rngUnion" in relation
                    ' to the corresponding cell address
                    Set rngUnion = Application.Union(rngUnion, .Cells(lngRow, 5))
                    ' Create a named range
                    ThisWorkbook.Names.Add Name:=.Cells(lngRow, 4).Value, _
                        RefersTo:="=" & .Name & "!" & rngUnion.Address
                    ' Reset the object variable
                    Set rngUnion = Nothing
                End If
            ' Otherwise...
            Else
                ' If the object variable "rngUnion" is not yet occupied, then...
                If Not rngUnion Is Nothing Then
                    ' Set the object variable "rngUnion" in relation
                    ' to the corresponding cell address
                    Set rngUnion = Application.Union(rngUnion, .Cells(lngRow, 5))
                ' Otherwise...
                Else
                    ' The object variable "rngUnion" is created the first time
                    Set rngUnion = .Cells(lngRow, 5)
                End If
            End If
        ' The next cell
        Next lngRow
    End With
    ' This macro is invoked only for testing - the call can later be deleted
    Call Main_1
Fin:
    ' Reset the object variable
    Set rngUnion = Nothing
    ' If an error occurs print it out with the error number and description
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
' This subroutine is only needed to test
Private Sub Main_1()
    Dim strTMP As String
    Dim objName As Name
    If ThisWorkbook.Names.Count > 0 Then
        For Each objName In ThisWorkbook.Names
            strTMP = strTMP & objName.Name & " " & objName.RefersTo & vbCrLf
        Next objName
    Else
        MsgBox "No named ranges available!"
    End If
    If strTMP <> "" Then MsgBox strTMP
End Sub
' With this routine, all named ranges are deleted.
Public Sub Names_Delete()
    Dim objName As Name
    On Error GoTo Fin
    For Each objName In ThisWorkbook.Names
        objName.Delete
    Next objName
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

Tabellen - ListObjects vorhanden - prüfen und Informationen ausgeben...

Frage: In einer Tabelle habe ich mehrere Tabellen (ListObjects) eingefügt. Wie kann ich per VBA das Vorhandensein dieser Tabellen prüfen? Wenn möglich ohne "On Error Resume Next" oder sonstige Errorhandler.

In a table I have included several tables (ListObjects). How can I check for the existence of these tables via VBA? If possible without "On Error Resume Next" or other error handler.

Hier noch eine Beispieldatei / Here's a sample file:
Tabellen - ListObjects vorhanden - prüfen und Informationen ausgeben...[ZIP 20 KB]

' Variablendeklaration erforderlich
Option Explicit
'--------------------------------------------------------------------------
' Module    : Module1
' Procedure : Main
' Author    : Case (Ralf Stolzenburg)
' Date      : 23.10.2013
' Purpose   : Tabellen - ListObjects vorhanden und Informationen...
'--------------------------------------------------------------------------
Sub Main()
    ' Wenn die "Tabelle" Table1 im Sheet1 vorhanden ist dann...
    If fncListObjects("Table1", "Sheet1") = True Then
        MsgBox "ListObject exists!"
    ' Sonst...
    Else
        MsgBox "ListObject does not exist!"
    End If
End Sub
Sub Main_1()
    ' Wenn die "Tabelle" Table123 im Sheet1 vorhanden ist dann...
    If fncListObjects("Table123", "Sheet1") = True Then
        MsgBox "ListObject exists!"
    ' Sonst...
    Else
        MsgBox "ListObject does not exist!"
    End If
End Sub
Sub Main_2()
    ' Wenn die "Tabelle" Table1 im Sheet123 vorhanden ist dann...
    If fncListObjects("Table1", "Sheet123") = True Then
        MsgBox "ListObject exists!"
    ' Sonst...
    Else
        MsgBox "ListObject does not exist!"
    End If
End Sub
' Funktion die den Namen des Listobjektes und den Tabellenblattnamen
' jeweils als String erwartet und einen Boolean-Wert
' (Wahr oder Falsch) zurückliefert
Private Function fncListObjects(ByVal strName As String, _
    ByVal strSheet As String) As Boolean
    Dim objList As Object
    ' Wenn das übergebene Tabellenblatt vorhanden ist, dann...
    If fncSheetEx(strSheet) = True Then
        ' Gehe durch alle Listobjekte auf dem Tabellenblatt
        For Each objList In ThisWorkbook.Worksheets(strSheet).ListObjects
            ' Wenn der Name des Listobjektes übereinstimmt, dann...
            If objList.Name = strName Then
                ' Funktion gibt Wahr zurück
                fncListObjects = True
                ' Arbeit erledigt, verlasse die Funktion
                Exit Function
            Else
                ' Sonst gibt die Funktion Falsch zurück
                fncListObjects = False
            End If
        Next objList
    Else
        ' Das Tabellenblatt ist nicht vorhanden
        MsgBox "Worksheet does not exist!"
        ' Beendet sofort alle Makros, setzt alle Variablen zurück
        End
    End If
End Function
' Funktion um das Vorhandensein von Tabellenblättern zu prüfen
' Evaluate wertet einen String aus
' ISREF ist eine Worksheet Funktion die True/False bezogen auf
' eine gültige Zellreferenz zurückliefert
Private Function fncSheetEx(ByVal strSheet As String) As Boolean
    fncSheetEx = Evaluate("ISREF(" & strSheet & "!A1)")
End Function
' Alle Tabellen (ListObjects) - Namen, Bereich und Tablestyle ausgeben
Sub Main_3()
    Dim objList As Object
    For Each objList In ThisWorkbook.Worksheets(ActiveSheet.Name).ListObjects
        Debug.Print objList.Name
        Debug.Print objList.Range.Address(False, False)
        Debug.Print objList.TableStyle.NameLocal
    Next objList
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 ...