VBA und VB DOT.NET

Tabellenblatt einfügen abfangen Vorlage kopieren

2011-07-19T23:59:00.003+02:00

Wie kann (M)man(n) das einfügen von Tabellenblättern Applikationsweit abfangen um eine eigene Vorlage einzufügen? Das ganze soll als Addin laufen. Da gibt es ja das Ereignis "Private Sub Workbook_NewSheet(ByVal Sh As Object)" in "DieseArbeitsmappe". Das greifen wir uns und packen alles in ein Addin. Um das zu knacken sollte (M)man(n) in der Hilfe nach "WorkbookNewSheet" schauen.

Tabellenblatt einfügen abfangen Vorlage kopieren...[ZIP, 70 KB]

' Code in "DieseArbeitsmappe"
Option Explicit
Dim AppObject As New clsDatei
Private Sub Workbook_Open()
    Set AppObject.AppLiCa = Application
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set AppObject.AppLiCa = Nothing
End Sub

' Code in ein Klassenmodul mit Namen "clsDatei"
Option Explicit
Public WithEvents AppLiCa As Application
Private Sub AppLiCa_WorkBookNewSheet(ByVal Wb As Workbook, _
    ByVal Sh As Object)
    On Error GoTo Fin
    With AppLiCa
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    With Wb
        .Worksheets(.Worksheets.Count).Delete
        ThisWorkbook.Worksheets("Vorlage").Copy _
            After:=.Worksheets(Worksheets.Count)
        .Worksheets(Worksheets.Count).Name = "New" & .Worksheets.Count
    End With
Fin:
    With AppLiCa
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

Geschlossene Dateien - ADO - Tabellenblatt!

2011-06-30T13:38:00.003+02:00

Frage: Der Tabellenblattname kann nicht genau festgelegt werden. Es können zwei verschiedene Namen sein. Dies geht aber nicht, wenn quasi geschlossene Dateien per Formel ausgelesen werden. Hier wird per ADO geprüft, welches Tabellenblatt in der Datei ist.

Geschlossene Dateien - ADO - Tabellenblatt...[ZIP, 140 KB]

Option Explicit
Const strSheetZ As String = "Tabelle1" ' Die Tabelle in dieser Datei
Const strCellQ1 As String = "L8" ' Die Zelle wird ausgelesen
Const strCellQ2 As String = "L6" ' Die Zelle wird ausgelesen
Public Sub Files_Read()
    Dim stCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        stCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Wenn der Inhalt vorher gelöscht werden soll
    ' ThisWorkbook.Worksheets(strSheetZ).Columns("A:C").ClearContents
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Datei im gleichen Ordner wie Auswertungsdateien
    strDir = ThisWorkbook.Path
    Set objDir = objFSO.GetFolder(strDir)
    'dirInfo objDir, "*.xls*", True ' Mit Unterordner
    dirInfo objDir, "*.xls*"
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = stCalc
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
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 strSheet As String
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And varTMP.Name <> _
            ThisWorkbook.Name Then
            If Left(varTMP.Name, 1) <> "~" Then
                strSheet = ADOSheet(varTMP.Path)
                With ThisWorkbook.Worksheets(strSheetZ)
                    lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
                        .Rows.Count, .Cells(.Rows.Count, 2).End(xlUp).Row) + 1
                    With .Cells(lngLastRow, 2)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, _
                            "\") + 1) & "]" & _
                            strSheet & "'!" & strCellQ1
                        .Value = .Value
                        .Offset(0, -1).Value = varTMP.Name
                    End With
                    With .Cells(lngLastRow, 3)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, _
                            "\") + 1) & "]" & _
                            strSheet & "'!" & strCellQ2
                        .Value = .Value
                    End With
                End With
            End If
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, blnTMP
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub
Private Function ADOSheet(ByVal strFileName As String) As String
    Dim strSheetQ1 As String
    Dim strSheetQ As String
    Dim objConn As Object
    Dim objCat As Object
    Dim objTab As Object
    On Error GoTo Fin
    strSheetQ1 = "Project_Data"
    strSheetQ = "Projektdaten"
    Set objConn = CreateObject("ADODB.Connection")
    With objConn
        .CursorLocation = 3 ' = adUseClient
        If Val(Application.Version) >= 12 Then
            .Provider = "Microsoft.ACE.OLEDB.12.0;" & _
                "Extended Properties=""Excel 12.0;HDR=YES"";" & _
                "Data Source=" & strFileName & ";"
        Else
            .Provider = "Microsoft.Jet.OLEDB.4.0;" & _
                "Extended Properties=Excel 8.0;" & _
                "Data Source=" & strFileName & ";"
        End If
        .Open
    End With
    Set objCat = CreateObject("ADOX.Catalog")
    Set objCat.ActiveConnection = objConn
    For Each objTab In objCat.Tables
        If objTab.Name Like "Project_*" Then
            ADOSheet = strSheetQ1: Exit Function
        ElseIf objTab.Name Like "Projektda*" Then
            ADOSheet = strSheetQ: Exit Function
        End If
    Next objTab
Fin:
    Set objCat = Nothing
    If Not objConn Is Nothing Then
    If objConn.State = 1 Then objConn.Close
    End If
    Set objConn = Nothing
End Function

Tabellenblätter Passwort einblenden/ausblenden!

2011-06-28T14:37:00.004+02:00

Über eine Startseite sollen alle Tabellenblätter nur mit Passwort eingeblendet werden können. Diese sind in der Regel ausgeblendet "xlSheetVeryHidden". Auswahl über eine UserForm. Wird auf die Startseite zurückgegangen wird das entsprechende Tabellenblatt wieder ausgeblendet.

Tabellenblätter Passwort einblenden/ausblenden...[ZIP, 60 KB]

' Code in ein Modul
Option Explicit
Option Private Module
Sub Alle_Ausblenden()
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name <> "Start" Then
            wksSheet.Visible = xlSheetVeryHidden
        End If
    Next wksSheet
End Sub
Sub UF_Show()
    UserForm1.Show
End Sub

' Code in UserForm1
Option Explicit
Private Sub UserForm_Activate()
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Name <> "Start" And wksSheet.Name <> "Pass" Then
            ComboBox1.AddItem (wksSheet.Name)
        End If
    Next wksSheet
    ComboBox1.ListIndex = 0
    With TextBox1
        .Text = ""
        .PasswordChar = "*"
        .MaxLength = 5
        .SetFocus
    End With
End Sub
Private Sub CommandButton2_Click()
    Unload Me
End Sub
Private Sub CommandButton1_Click()
    If Trim(TextBox1.Text) = "" Then
        MsgBox "Kennwort fehlt", vbOKOnly, "Nachricht"
        TextBox1.SetFocus
    ElseIf TextBox1.Text <> ThisWorkbook.Worksheets("Pass") _
        .Range(ComboBox1.Value) Then
        MsgBox "Kennwort falsch, wiederholen / abbrechen", _
            vbOKOnly, "Nachricht"
        TextBox1.Text = ""
        TextBox1.SetFocus
    Else
        ThisWorkbook.Worksheets _
            (ComboBox1.Value).Visible = xlSheetVisible
        Application.Goto ThisWorkbook.Worksheets _
            (ComboBox1.Value).Range("A1"), True
        Unload Me
    End If
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CloseMode = 0 Then Cancel = True
End Sub

' Code in diese Arbeitsmappe
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Alle_Ausblenden
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = "Start" Then Call Alle_Ausblenden
End Sub

Formeln - Werte - Speichern ohne Makros!

2011-06-16T13:11:00.003+02:00

Achtung - funktioniert nur in Excel 2007 bzw. 2010. Wenn man in Excel 2007/2010 eine XLSM-Datei mit Makros OHNE Makros speichern möchte, kann man diese Datei einfach als XLSX speichern und die Makros sind alle weg. Ein Button im Tabellenblatt (aus Formularsteuerelemente) löscht sich beim Klick durch "Application.Caller" von selber. Formeln werden durch die Werte ersetzt. Noch andere vorhandene Tabellenblätter werden gelöscht und die Datei dann mit "SaveAs" als XLSX gespeichert. Die Ursprungsdatei bleibt bestehen.

Formeln - Werte - Speichern ohne Makros...[ZIP, 50 KB]

Option Explicit
Const strFileName As String = "Dateiname"
Private Sub Test()
    Dim wksSheet As Worksheet
    Dim varPath As Variant
    On Error GoTo Fin
    Application.DisplayAlerts = False
    varPath = Application.GetSaveAsFilename( _
        InitialFileName:=ThisWorkbook.Path & "\" & strFileName, _
        FileFilter:="Excel(*.xlsx), *.xlsx", _
        Title:="Speichern ohne Makros")
    If Not varPath = False Then
        For Each wksSheet In ThisWorkbook.Worksheets
            If wksSheet.Name <> ActiveSheet.Name Then
                wksSheet.Delete
            End If
        Next wksSheet
        With ActiveSheet
            .Shapes(Application.Caller).Delete
            .UsedRange.Value = .UsedRange.Value
        End With
        With ThisWorkbook
            .SaveAs varPath, 51
            .Close False
        End With
    End If
Fin:
    Application.DisplayAlerts = True
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

Ausgeblendete Tabellenblätter Inhalt anzeigen!

2011-06-15T10:08:00.003+02:00

Es soll nur ein Tabellenblatt sichtbar sein. Alle restlichen Sheets sind per "xlSheetVeryHidden" ausgeblendet. In einer ComboBox auf dem ersten Tabellenblatt können die Tabellenblätter ausgewählt und der Inhalt angezeigt werden.

Ausgeblendete Tabellenblätter Inhalt anzeigen...[ZIP, 70 KB]

Option Explicit
Private Sub Workbook_Open()
    Dim intTMP As Integer
    On Error GoTo Fin
    With Tabelle1
        .ComboBox1.Clear
        .ComboBox1.AddItem ("Auswahl...")
        For intTMP = 1 To ThisWorkbook.Worksheets.Count
            If ThisWorkbook.Worksheets(intTMP).Index > 1 Then
                .ComboBox1.AddItem _
                    (ThisWorkbook.Worksheets(intTMP).Name)
            End If
        Next intTMP
        .ComboBox1.ListIndex = 0
    End With
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim wksSheet As Worksheet
    For Each wksSheet In ThisWorkbook.Worksheets
        If wksSheet.Index > 1 Then _
            wksSheet.Visible = xlSheetVeryHidden
    Next wksSheet
End Sub

Daten Spalte B jeweils in neue Dateien aufteilen!

2011-06-15T09:35:00.003+02:00

Frage aus Office-Loesung: Werte aus Spalte B die jeweils ein- oder auch mehrmals unsortiert vorliegen, sollen in neue Dateien abgespeichert werden. Im folgenden Beispiel von Spalte A bis Spalte D. Gelöst über temporäre Tabellenblätter und den Spezialfilter. Eventuell vorhandene Dateien mit gleichem Namen werden ohne Nachfrage überschrieben.

Daten Spalte B jeweils in neue Dateien aufteilen...[ZIP, 50 KB]

Option Explicit
Public Sub Aufteilen()
    Dim wksKriterienSheet As Worksheet
    Dim wksQuellSheet As Worksheet
    Dim rngKriterium As Range
    Dim wksNew As Worksheet
    Dim wkbBook As Workbook
    Dim lngLastRow As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    ' Tabellenblatt mit Daten - Name ANPASSEN
    Set wksQuellSheet = Worksheets("Gesamt")
    Set wksKriterienSheet = Worksheets.Add
    wksKriterienSheet.Move After:= _
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    lngLastRow = wksQuellSheet.Range("B" & Rows.Count).End(xlUp).Row
    wksQuellSheet.Range("B1:B" & lngLastRow).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=wksKriterienSheet.Range("A1"), Unique:=True
    Set rngKriterium = wksKriterienSheet.Range("A2")
    While rngKriterium.Value <> ""
        Set wksNew = Worksheets.Add
        wksQuellSheet.Range("A1:D" & lngLastRow).AdvancedFilter _
            Action:=xlFilterCopy, _
            CriteriaRange:=rngKriterium.Offset(-1).Resize(2), _
            CopyToRange:=wksNew.Range("A1"), Unique:=True
        wksNew.Name = rngKriterium.Text
        rngKriterium.EntireRow.Delete
        wksNew.Copy
        Set wkbBook = ActiveWorkbook
        If Val(Application.Version) < 12 Then
            wkbBook.SaveAs ThisWorkbook.Path & _
                "\" & wksNew.Name & ".xls"
        Else
            wkbBook.SaveAs ThisWorkbook.Path & _
                "\" & wksNew.Name, 56
        End If
        wkbBook.Close SaveChanges:=False
        Set wkbBook = Nothing
        wksNew.Delete
        Set wksNew = Nothing
        Set rngKriterium = Nothing
        Set rngKriterium = wksKriterienSheet.Range("A2")
    Wend
    wksKriterienSheet.Delete
    Set wksKriterienSheet = Nothing
Fin:
    If Not wksNew Is Nothing Then _
        wksNew.Delete
    If Not wksKriterienSheet Is Nothing Then _
        wksKriterienSheet.Delete
    With Application
        .Goto wksQuellSheet.Range("A1"), True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    Set wkbBook = Nothing
    Set wksKriterienSheet = Nothing
    Set wksQuellSheet = Nothing
    Set rngKriterium = Nothing
    Set wksNew = Nothing
End Sub

Heutiges Datum - Spalte A - Finden - Markieren!

2011-06-07T08:27:00.003+02:00

In Spalte A stehen die Tage des jeweiligen Jahres in der Form 01.01.2011 bis 31.12.2011. Es soll nun zum aktuellen Datum gesprungen werden. Dazu nutze ich die "FollowHyperlink-Prozedur" des Worksheetobjektes. Der Code gehört in den Codebereich des entsprechenden Tabellenblattes.

Heutiges Datum - Spalte A - Finden - Markieren...[ZIP, 50 KB]

Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
    Application.Goto Range("A:A").Find _
        (Date, LookIn:=xlValues, LookAt:=xlPart), True
End Sub

Worddateien - Tabelle nach Excel kopieren!

2011-05-26T12:03:00.002+02:00

Frage: Aus vielen Worddokumenten soll eine Tabelle in Excel kopiert werden - jeweils auf ein neues Tabellenblatt. Es kann auch der gesamte Inhalt des Worddokumentes kopiert werden. Bitte den Pfad im Code anpassen.

Worddateien - Tabelle nach Excel kopieren...[ZIP, 90 KB]

Option Explicit
Dim blnTMP As Boolean
Public Sub Test()
    Dim objDocument As Object
    Dim strDatei As String
    Dim strPfad As String
    Dim objApp As Object
    On Error GoTo Fin
    ' Pfad anpassen
    strPfad = "C:\TMP\"
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        strDatei = Dir$(strPfad & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            Set objDocument = objApp.Documents.Open _
                (strPfad & strDatei)
            ' Die erste Tabelle wird kopiert
            objDocument.Tables(1).Range.Copy
            ' Der gesamte Inhalt wird kopiert
            'objDocument.Range.Copy
            ' und in ein neues Tabellenbatt eingefügt
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Paste
            ' Worddokument ohne speichern schlissen
            objDocument.Close False
            ' Die nächste Datei nehmen
            strDatei = Dir$()
        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
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        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

Protokoll - Datum - Tabellen!

2011-05-12T14:58:00.001+02:00

Um zu sehen, ob ein Tabellenblatt aktuell ist sollen bei Änderungen in ein extra Tabellenblatt das Datum und die Uhrzeit protokolliert werden. Das Tabellenblatt heisst in meinem Beispiel "Protokoll" und ist ausgeblendet. Für jedes andere Tabellenblatt habe ich auf dem Sheet "Protokoll" einen Namen angelegt mit dem CodeNamen des jeweiligen Tabellenblattes. Protokolliert wird Tabellenblattname, CodeName des Tabellenblattes, Datum und Uhrzeit und der Username. Protokolliert wird auch, wenn alle Tabellenblätter markiert sind um Eingaben auf allen zu machen.

Protokoll - Datum - Tabellen...[ZIP, 60 KB]

' Folgender Code in "DieseArbeitsmappe":
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    If Sh.CodeName <> "Tabelle4" Then
        With Tabelle4
            .Unprotect
            .Range(Sh.CodeName).Value = Sh.CodeName
            .Range(Sh.CodeName).Offset(, 1).Value = Sh.Name
            .Range(Sh.CodeName).Offset(, 2).Value = _
                Format(Now, "DD.MM.YYYY HH:MM:SS")
            .Range(Sh.CodeName).Offset(, 3).Value = Environ("UserName")
            .Protect UserInterfaceOnly:=True
        End With
    End If
Fin:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

Datei suchen - Pfad unbekannt - auslesen - kopieren!

2011-05-12T12:23:00.001+02:00

Frage: Wie kann man eine Datei suchen, die irgendwo auf dem PC ist? Der Pfad ist nicht bekannt. Hier bietet sich die API-Funktion "SearchTreeForFile" an. Im folgenden Beispiel wird die Datei "Testdatei.xls" auf Laufwerk "C:\" gesucht. Wird sie gefunden können über die zwei folgenden Codes entweder zwei Zellen hineinkopiert bzw. zwei Zellen herausgelesen werden.

Datei suchen - Pfad unbekannt - auslesen - kopieren...[ZIP, 60 KB]

' Code für auslesen - kommt in Modul1
Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, _
    ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
' Anpassungen eventuell vornehmen!!!
Const strFile As String = "Testdatei.xls"
Const strSheetQ As String = "Tabelle1"
Const strCell1 As String = "E1"
Const strCell2 As String = "E2"
Sub Test()
    Dim strPathName As String * 255
    Dim strName As String
    Dim lngTMP As Long
    On Error GoTo Fin
    lngTMP = SearchTreeForFile("C:\", strFile, strPathName)
    If lngTMP = 0 Then
        Debug.Print "Datei nicht vorhanden"
    Else
        strPathName = Left$(strPathName, _
            InStr(1, strPathName, vbNullChar) - 1)
        strName = RTrim(strPathName)
        With Tabelle1.Cells(1, 1)
            .Formula = "='" & Mid(strName, 1, _
                InStrRev(strName, "\")) & "[" & _
                Mid(strName, InStrRev(strName, "\") + 1) & "]" & _
                strSheetQ & "'!" & strCell1
            .Value = .Value
        End With
        With Tabelle1.Cells(1, 2)
            .Formula = "='" & Mid(strName, 1, _
                InStrRev(strName, "\")) & "[" & _
                Mid(strName, InStrRev(strName, "\") + 1) & "]" & _
                strSheetQ & "'!" & strCell2
            .Value = .Value
        End With
    End If
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

' Code für reinkopieren - kommt in Modul2
Option Explicit
Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
    (ByVal RootPath As String, _
    ByVal InputPathName As String, _
    ByVal OutputPathBuffer As String) As Long
' Anpassungen eventuell vornehmen!!!
Const strFile As String = "Testdatei.xls"
Const strSheetQ As String = "Tabelle1"
Const strCell1 As String = "E1"
Const strCell2 As String = "E2"
Sub Test_1()
    Dim strPathName As String * 255
    Dim wkbBook As Workbook
    Dim strName As String
    Dim lngCalc As Long
    Dim lngTMP As Long
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    lngTMP = SearchTreeForFile("C:\", strFile, strPathName)
    If lngTMP = 0 Then
        Debug.Print "Datei nicht vorhanden"
    Else
        strPathName = Left$(strPathName, _
            InStr(1, strPathName, vbNullChar) - 1)
        strName = RTrim(strPathName)
        Set wkbBook = Workbooks.Open(strName)
        With wkbBook.Worksheets(strSheetQ)
            .Cells(1, 1).Value = Tabelle1.Range(strCell1)
            .Cells(1, 2).Value = Tabelle1.Range(strCell2)
        End With
        wkbBook.Close True
    End If
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
    End With
    Set wkbBook = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub

Access - bestimmte Werte auslesen!

2011-04-14T08:03:00.003+02:00

Unabhängig von dem allseits bekannten "Daten bzw. Daten - externe Daten importieren" folgend eine VBA-Lösung. Um dieses Beispiel nachvollziehen zu können muss zunächst die ENGLISCHE Version der Nordwinddatenbank aus dem Netz gezogen werden:

ENGLISCHE Version der Nordwinddatenbank

Im Code dann noch den Pfad anpassen und fertig. Es werden verschiedene Informationen aus der Tabelle "Employees" ausgelesen und über zwei Arten ausgegeben. Einmal über "CopyFromRecordset" und dann noch über eine "For-Schleife". Access muss nicht installiert sein.

Access - bestimmte Werte auslesen...[ZIP, 60 KB]

' Code in ein allgemeines Modul:

' Download ENGLISCHE Nordwinddatenbank http://tinyurl.com/2zm2mn
Option Explicit
' Pfad- und Dateiname anpassen
Const strFileName As String = "nwind.mdb"
Const strPath As String = "C:\Test\"
' Name der Accesstabelle bei Bedarf anpassen
Const strTableName As String = "Employees"
Public Sub DatenbankNWIND(ByVal lngRow As Long)
    Dim strUpdate As String
    Dim intCount As Integer
    Dim rcsEntry As Object
    Dim objConn As Object
    Dim blnTMP As Boolean
    On Error GoTo Fin
    If Dir(strPath & strFileName) = "" Then
        MsgBox "Datei nicht vorhanden!"
    Else
        strUpdate = Tabelle1.Cells(lngRow, 1).Value
        If Trim(strUpdate) = "" Then MsgBox "A1 leer!": Exit Sub
        If strUpdate = False Then Exit Sub
        Set rcsEntry = CreateObject("ADODB.Recordset")
        Set objConn = CreateObject("ADODB.Connection")
        With objConn
            .CursorLocation = 3 ' = adUseClient
            If Val(Application.Version) >= 12 Then
                .Provider = "Microsoft.ACE.OLEDB.12.0"
            Else
                .Provider = "Microsoft.Jet.OLEDB.4.0"
            End If
            .Properties("Data Source") = strPath & strFileName
            .Open
        End With
        With rcsEntry
            .ActiveConnection = objConn
            .CursorLocation = 3 ' = adUseClient
            .LockType = 3 ' = adLockOptimistic
            .CursorType = 1 ' = adOpenKeyset
            .Source = "SELECT LastName, FirstName, Title, City FROM " & _
                strTableName & " WHERE EmployeeID=" & strUpdate
            .Open
            If .RecordCount <> 0 Then
                .MoveFirst
                For intCount = 0 To rcsEntry.Fields.Count - 1
                    Tabelle1.Cells(intCount + 1, 8).Value = _
                        rcsEntry.Fields(intCount).Value
                Next intCount
                ' Oder andere Ausgabe der Informationen
                Tabelle1.Cells(lngRow, 2).CopyFromRecordset rcsEntry
            Else
                Tabelle1.Rows(lngRow).ClearContents
                Tabelle1.Columns(8).ClearContents
                MsgBox "ID in Datenbank nicht vorhanden!"
            End If
        End With
    End If
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    If Not rcsEntry Is Nothing Then
        If rcsEntry.State = 1 Then rcsEntry.Close
    End If
    If Not objConn Is Nothing Then
        If objConn.State = 1 Then objConn.Close
    End If
    Set rcsEntry = Nothing
    Set objConn = Nothing
End Sub


' Code in das Klassenmodul der Tabelle:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo Fin
    If Trim(Target.Value) = "" Then
        Rows(Target.Row).ClearContents
        Columns(8).ClearContents
    Else
        If Target.Count > 1 Or Trim(Target.Text) = "" Or _
            Not IsNumeric(Target) Then Exit Sub
        If Not Intersect(Target, Columns(1)) Is Nothing Then
            Application.EnableEvents = False
            Call DatenbankNWIND(Target.Row)
        End If
    End If
Fin:
    Application.EnableEvents = True
End Sub

Nützliche Links:
Access - bestimmte Werte auslesen - Linkliste [TXT]

Geschlossene Dateien - Datum - Bedingung!

2011-03-31T10:37:00.005+02:00

Eine unerschöpfliche Quelle - geschlossene Dateien auslesen. Hier eine Frage aus Office-Loesung. Aus Tabellenblatt 1 sollen 4 Werte ausgelesen werden, aus Tabellenblatt 2 Werte aus Spalten, aber nur jede zweite. Zusätzlich ist auf Tabellenblatt 2 in Zelle E3 ein Datum. Es darf erst mit dem Auslesen ab dem Datum begonnen werden. Im ersten Code wird alles ausgelesen, im zweiten Code ist die Datumsbedingung mit eingearbeitet. Bitte erst die ReadMe.txt im Download lesen!

Geschlossene Dateien - Datum - Bedingung mit Beispieldateien...[ZIP, 160 KB]

' Code gehört in Modul1

Option Explicit
' Die Tabelle wird ausgelesen
Const strSheetQ1 As String = "Tabelle1"
' Die Tabelle wird ausgelesen
Const strSheetQ2 As String = "Tabelle2"
' Die Tabelle in dieser Datei
Const strSheetZ As String = "Gesamt"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C"
' Die Zeile in Tabelle2 wird ausgelesen
Const lngRow As Long = 10
Public Sub Files_Read()
    Dim strListing As String
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        intCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Mit Ordnerauswahl - dann die entsprechenden unteren
    ' Codezeilen auskommentieren
'    If funcDirectory(strDir) <> "" Then
'        Set objDir = objFSO.GetFolder(strDir)
'        ThisWorkbook.Worksheets(strSheetZ).Rows _
'            ("2:" & Rows.Count).ClearContents
'        'dirInfo objDir, "*.xls*", True ' Mit Unterordner
'        dirInfo objDir, "*.xls*"
'    End If
    ' Datei im gleichen Ordner wie Auswertungsdateien
    'strDir = ThisWorkbook.Path
    ' Datei im fest vorgegebenen Ordner
    strDir = "C:\Temp\Test1"
    Set objDir = objFSO.GetFolder(strDir)
    ThisWorkbook.Worksheets(strSheetZ).Rows _
        ("2:" & Rows.Count).ClearContents
    'dirInfo objDir, "*.xls*", True ' Mit Unterordner
    dirInfo objDir, "*.xls*"
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = intCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
Private 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 intCount As Integer
    Dim strSpalte As String
    Dim lngLastRow As Long
    Dim intTMP As Integer
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And _
            varTMP.Name <> ThisWorkbook.Name And _
            Left(varTMP.Name, 1) <> "~" Then
            With ThisWorkbook.Worksheets(strSheetZ)
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
                    .Rows.Count, .Cells(.Rows.Count, 2) _
                        .End(xlUp).Row) + 1
                .Cells(lngLastRow, 1).Value = varTMP.Name
                ' Mit Pfad
                '.Cells(lngLastRow, 1).Value = varTMP.Path
                For intTMP = 4 To 7
                    With .Cells(lngLastRow, intTMP - 2)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, _
                            "\") + 1) & "]" & _
                            strSheetQ1 & "'!" & strCellQ1 & intTMP
                        .Value = .Value
                    End With
                Next intTMP
                intCount = 0
                For intTMP = 13 To 135 Step 2
                    strSpalte = Mid(.Columns(intTMP).Address, InStr _
                        (2, .Columns(intTMP).Address, "$") + 1)
                    With .Cells(lngLastRow, intCount + 6)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, _
                            "\") + 1) & "]" & _
                            strSheetQ2 & "'!" & strSpalte & lngRow
                        .Value = .Value
                        intCount = intCount + 1
                    End With
                Next intTMP
            End With
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, True
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub
Private Function funcDirectory(strDirectory As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Directory"
        .ButtonName = "Select..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strDirectory = .SelectedItems(1)
            If Right(strDirectory, 1) <> "\" Then _
                strDirectory = strDirectory & "\"
        Else
            strDirectory = ""
        End If
    End With
    funcDirectory = strDirectory
End Function


' Code gehört in Modul2

Option Explicit
' Die Tabelle wird ausgelesen
Const strSheetQ1 As String = "Tabelle1"
' Die Tabelle wird ausgelesen
Const strSheetQ2 As String = "Tabelle2"
' Die Tabelle in dieser Datei
Const strSheetZ As String = "Gesamt"
' Die Zelle wird ausgelesen
Const strCellQ1 As String = "C"
' Die Zelle mit dem Datum
Const strCellQ2 As String = "E3"
' Die Zeile in Tabelle2 wird ausgelesen
Const lngRow As Long = 10
Public Sub Files_Read_1()
    Dim strListing As String
    Dim intCalc As Integer
    Dim strDir As String
    Dim objFSO As Object
    Dim objDir As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .AskToUpdateLinks = False
        .EnableEvents = False
        intCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    ' Mit Ordnerauswahl - dann die entsprechenden unteren
    ' Codezeilen auskommentieren
'    If funcDirectory(strDir) <> "" Then
'        Set objDir = objFSO.GetFolder(strDir)
'        ThisWorkbook.Worksheets(strSheetZ).Rows _
'            ("2:" & Rows.Count).ClearContents
'        'dirInfo objDir, "*.xls*", True ' Mit Unterordner
'        dirInfo objDir, "*.xls*"
'    End If
    ' Datei im gleichen Ordner wie Auswertungsdateien
    'strDir = ThisWorkbook.Path
    ' Datei im fest vorgegebenen Ordner
    strDir = "C:\Temp\Test1"
    Set objDir = objFSO.GetFolder(strDir)
    ThisWorkbook.Worksheets(strSheetZ).Rows _
        ("2:" & Rows.Count).ClearContents
    'dirInfo objDir, "*.xls*", True ' Mit Unterordner
    dirInfo objDir, "*.xls*"
Fin:
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = intCalc
        .DisplayAlerts = True
    End With
    Set objDir = Nothing
    Set objFSO = Nothing
End Sub
Private 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 intCount As Integer
    Dim strSpalte As String
    Dim lngLastRow As Long
    Dim intTMP As Integer
    Dim varTMP As Variant
    For Each varTMP In objCurrentDir.Files
        If varTMP.Name Like strName And _
            varTMP.Name <> ThisWorkbook.Name And _
            Left(varTMP.Name, 1) <> "~" Then
            With ThisWorkbook.Worksheets(strSheetZ)
                lngLastRow = IIf(Len(.Cells(.Rows.Count, 2)), _
                    .Rows.Count, .Cells(.Rows.Count, 2) _
                        .End(xlUp).Row) + 1
                .Cells(lngLastRow, 1).Value = varTMP.Name
                ' Mit Pfad
                '.Cells(lngLastRow, 1).Value = varTMP.Path
                For intTMP = 4 To 7
                    With .Cells(lngLastRow, intTMP - 2)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, _
                            "\") + 1) & "]" & _
                            strSheetQ1 & "'!" & strCellQ1 & intTMP
                        .Value = .Value
                    End With
                Next intTMP
                intCount = 0
                With .Cells(1, 5)
                    .Formula = "='" & Mid(varTMP.Path, 1, _
                        InStrRev(varTMP.Path, "\")) & "[" & _
                        Mid(varTMP.Path, InStrRev(varTMP.Path, _
                        "\") + 1) & "]" & _
                        strSheetQ2 & "'!" & strCellQ2
                    .Value = .Value
                    .NumberFormat = "m/d/yyyy"
                End With
                For intTMP = 13 To 135 Step 2
                    strSpalte = Mid(.Columns(intTMP).Address, InStr _
                        (2, .Columns(intTMP).Address, "$") + 1)
                    With .Cells(lngLastRow, intCount + 6)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, _
                            "\") + 1) & "]" & _
                            strSheetQ2 & "'!" & strSpalte & lngRow - 7
                        .Value = .Value
                        .NumberFormat = "m/d/yyyy"
                        With ThisWorkbook.Worksheets(strSheetZ)
                            If CLng(.Cells _
                                (lngLastRow, intCount + 6).Value) = _
                                CLng(.Cells _
                                (1, 5).Value) Then
                                .Cells(1, 5).ClearContents
                                Exit For
                            End If
                        End With
                    End With
                Next intTMP
                For intTMP = intTMP To 135 Step 2
                    strSpalte = Mid(.Columns(intTMP).Address, InStr _
                        (2, .Columns(intTMP).Address, "$") + 1)
                    With .Cells(lngLastRow, intCount + 6)
                        .Formula = "='" & Mid(varTMP.Path, 1, _
                            InStrRev(varTMP.Path, "\")) & "[" & _
                            Mid(varTMP.Path, InStrRev(varTMP.Path, _
                            "\") + 1) & "]" & _
                            strSheetQ2 & "'!" & strSpalte & lngRow
                        .Value = .Value
                        .NumberFormat = "m/d/yyyy"
                        If .Cells(lngLastRow, intCount + 6) = _
                            .Cells(lngLastRow, intCount + 5) Then
                            intCount = intCount + 1
                        End If
                    End With
                Next intTMP
            End With
        End If
    Next varTMP
    If blnTMP = True Then
        For Each varTMP In objCurrentDir.SubFolders
            dirInfo varTMP, strName, True
        Next varTMP
    End If
    Set objWorkbook = Nothing
End Sub
Private Function funcDirectory(strDirectory As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Directory"
        .ButtonName = "Select..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strDirectory = .SelectedItems(1)
            If Right(strDirectory, 1) <> "\" Then _
                strDirectory = strDirectory & "\"
        Else
            strDirectory = ""
        End If
    End With
    funcDirectory = strDirectory
End Function

UserForm - Suchen - Ändern - Neu anlegen!

2011-03-25T09:49:00.007+01:00

Frage aus dem Herber-Forum: Über eine UserForm soll in einem Tabellenblatt in Spalte A der in einer TextBox1 eingegebene Wert gesucht werden. Wird er gefunden soll in TextBox2 der korrespondierende Wert aus Spalte B angezeigt werden. Änderungen können nun vorgenommen und anschließend in das Tabellenblatt an die entsprechende Stelle zurück gespeichert werden. Ist der Wert nicht vorhanden, soll er am Ende neu angelegt werden.

UserForm - Suchen - Ändern - Neu anlegen...[ZIP, 60 KB]

' Code gehört in UserForm1

Option Explicit
 Private Sub TextBox1_Change()
     Dim varTMP As Variant
     With Tabelle2
         varTMP = Application.Match(TextBox1.Text, .Range("A:A"), 0)
         If Not IsError(varTMP) Then
             Me.Tag = varTMP
             TextBox2.Text = .Cells(varTMP, 2).Value
         Else
             Me.Tag = ""
             TextBox2.Text = ""
         End If
     End With
 End Sub
 Private Sub CommandButton1_Click()
     Dim lngRow As Long
     If Trim(TextBox1.Text) <> "" And Trim(TextBox2.Text) <> "" Then
         If Me.Tag <> "" Then
             With Tabelle2
                 .Cells(Me.Tag, 1).Value = TextBox1.Text
                 .Cells(Me.Tag, 2).Value = TextBox2.Text
             End With
         Else
             With Tabelle2
                 lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                 .Cells(lngRow, 1) = TextBox1.Text
                 .Cells(lngRow, 2) = TextBox2.Text
             End With
         End If
         TextBox1.Text = ""
         TextBox2.Text = ""
     Else
         MsgBox ("Eingabe unvollständig!")
         TextBox1.SetFocus
     End If
 End Sub
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
   If KeyAscii >= Asc("a") And KeyAscii <= Asc("z") Then _
    KeyAscii = KeyAscii + Asc("A") - Asc("a")
End Sub
Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
   If KeyAscii >= Asc("a") And KeyAscii <= Asc("z") Then _
    KeyAscii = KeyAscii + Asc("A") - Asc("a")
End Sub

API - Timer - Tabellenblattschutz prüfen!

2011-03-24T10:28:00.015+01:00

Frage aus Office-Loesung: Kann man das Setzen bzw. Aufheben des Tabellenblattschutzes überwachen? Ja - das geht per API. Wird der Tabellenblattschutz aufgehoben, dann wird der CommandButton ROT, sonst Grün.

API - Timer - Tabellenblattschutz prüfen...[ZIP, 50 KB]

Hinweise:
API - Set Timer

API - Kill Timer

Option Explicit
Private Declare Function KillTimer Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" _
    (ByVal hWnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public lngTimer As Long
Sub SchutzAktiv(ByVal hWnd As Long, ByVal lngMsg As Long, _
    ByVal lngEla As Long, ByVal lngFunc As Long)
    If lngMsg = &H113 Then
        With Tabelle1
            .CommandButton1.BackColor = IIf(Not .ProtectContents, &HFF&, &HC000&)
        End With
    End If
End Sub
Sub StartT()
    lngTimer = SetTimer(0, 0, 300, AddressOf SchutzAktiv)
End Sub
Sub StopT()
    KillTimer 0, lngTimer
End Sub

UserForm - Zahlen - Komma -Tabellenblatt!

2011-03-15T10:06:00.009+01:00

Frage: Wie kann man über eine UserForm Zahlen und Komma in Zellen eingeben? Die Windowsinterne Bildschirmtastatur (OSK) soll nicht verwendet werden. So:

UserForm - Zahlen - Komma -Tabellenblatt...[ZIP, 60 KB]

'Code in "DieseArbeitsmappe":

Option Explicit
Private Sub Workbook_Open()
    UserForm1.Show 0
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Terminate_Class
End Sub

'Code in ein Modul:

Option Explicit
Private objButton() As clsButton
Public Sub Terminate_Class()
    Dim lngIndex As Long
    If IsArray(objButton) Then
        For lngIndex = LBound(objButton) To UBound(objButton)
            Set objButton(lngIndex) = Nothing
        Next
    End If
    Erase objButton
End Sub

'Code in "UserForm1":

Option Explicit
Private objButton() As clsButton
Private Sub UserForm_Activate()
    Dim objControl As Control
    Dim lngCounter As Long
    For Each objControl In Controls
        If TypeOf objControl Is MSForms.CommandButton Then
            ReDim Preserve objButton(0 To lngCounter)
            Set objButton(lngCounter) = New clsButton
            Set objButton(lngCounter).SetButton = objControl
            lngCounter = lngCounter + 1
        End If
    Next objControl
End Sub
Private Sub Label1_Click()
    Unload Me
End Sub

'Code in einem Klassenmodul mit Namen "clsButton":

Option Explicit
Private WithEvents mobjButton As MSForms.CommandButton
Friend Property Set SetButton(objButton As MSForms.CommandButton)
    Set mobjButton = objButton
End Property
Private Sub mobjButton_Click()
    With ActiveSheet.Cells(ActiveCell.Row, ActiveCell.Column)
        .Value = .Value & mobjButton.Caption
    End With
    If Not mobjButton.Caption = "," Then
        ActiveSheet.Columns(ActiveCell.Column).TextToColumns
    End If
End Sub

Worddateien durchsuchen - auch mit Passwort!

2011-03-01T15:11:00.006+01:00

Einen älteren Blogeintrag etwas angepasst. In Worddateien - optional auch in Unterordnern - soll ein bestimmter Begriff gesucht werden. Wird der Begriff im Worddokument gefunden, soll das Dokument aufgelistet und mit einem Hyperlink versehen werden. Die Worddokumente können auch ein Kennwort haben, dass beim Öffnen verlangt wird.

Worddateien durchsuchen - auch mit Passwort...[ZIP, 280 KB]

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
    Alias "GetCurrentDirectoryA" _
    (ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
    Alias "SetCurrentDirectoryA" _
    (ByVal lpPathName$) As Long
Const strSearchTMP As String = "Calculation"
Const strEXT As String = "*.doc*"
Private strList() As String
Private objWDApp As Object
Private lngCount As Long
Private objFSO As Object
Public Sub Test()
    Dim strListing As String
    Dim strDirOld As String
    lngCount = 0
    On Error GoTo Fin
    strDirOld$ = String(255, 0)
    Call GetCurrentDirectory(255, strDirOld$)
    strDirOld$ = Left(strDirOld$, _
        InStr(1, strDirOld$, vbNullChar) - 1)
    If funcDirectory(strListing) <> "" Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objWDApp = CreateObject("Word.Application")
        Select Case MsgBox _
            ("Mit Unterordner ""Ja"" klicken, sonst ""Nein""!", _
            vbYesNo Or vbQuestion Or vbDefaultButton1, "Unterordner")
            Case vbYes
                SearchFiles strListing, strEXT, True
            Case vbNo
                SearchFiles strListing, strEXT
        End Select
        If lngCount = 0 Then
            MsgBox "No file with the search value found."
        Else
            With Sheet1
                .Cells.Clear
                .Range(.Cells(1, 1), Cells(lngCount, 1)) = _
                    WorksheetFunction.Transpose(strList)
            End With
            Call HyLink(Sheet1)
        End If
    End If
Fin:
    If Not objWDApp Is Nothing Then objWDApp.Quit
    Call SetCurrentDirectory(strDirOld$)
    Set objWDApp = Nothing
    Set objFSO = Nothing
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim objFolder As Object
    Dim objFile As Object
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            objWDApp.Documents.Open objFile.Path, _
                PasswordDocument:="12345"
            With objWDApp.Selection.Find
                .Forward = True
                .Text = strSearchTMP
                If .Execute = True Then
                    ReDim Preserve strList(lngCount)
                    strList(lngCount) = objFile.Path
                    lngCount = lngCount + 1
                    objWDApp.ActiveDocument.Close False
                End If
            End With
        End If
    Next
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            SearchFiles strFolder & "\" & objFolder.Name, _
                strFileName, blnTMP
        Next
    End If
End Sub
Private Function funcDirectory(strDirectory As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Directory"
        .ButtonName = "Select..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strDirectory = .SelectedItems(1)
            If Right(strDirectory, 1) <> "\" _
                Then strDirectory = strDirectory & "\"
            funcDirectory = strDirectory
        Else
            funcDirectory = ""
        End If
    End With
End Function
Private Sub HyLink(objSheet As Object)
    Dim lngRow As Long
    With objSheet
        lngRow = .Range("A" & .Rows.Count).End(xlUp).Row
        For lngRow = 1 To lngRow
            .Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
                Address:=.Cells(lngRow, 1), _
                TextToDisplay:=Mid(.Cells(lngRow, 1), _
                InStrRev(.Cells(lngRow, 1), "\", -1) + 1)
        Next lngRow
        .Columns("A:B").AutoFit
    End With
End Sub

UPDATE! Excel - PowerPoint - Textfelder - Diagramm!

2011-02-23T10:18:00.003+01:00

UPDATE!

Berechtigter Einwand: Das/die Diagramm(e) sollen entweder als Bild, oder als eingebettetes Objekt eingefügt werden. Damit die Übersicht gewahrt bleibt ein neuer Blogeintrag.

Hier der Link zum Vorhergehenden:
http://vbanet.blogspot.com/2011/02/excel-powerpoint-textfelder-diagramm.html

Immer wieder gefragt: Wie bekomme ich einen Bereich bzw. ein Diagramm in eine PowerPoint Datei, die auf einer Vorlage basiert? Für jedes Tabellenblatt soll eine Folie angelegt werden, bestimmte Werte in zu erzeugende Textfelder kopiert werden. Platzhalter bzw. Titel sollen befüllt werden. Dann soll noch das im jeweiligen Tabellenblatt eingebettete Diagramm auf die entsprechende Folie übernommen werden. Erstellt und getestet habe ich das in Excel 2010 (ergo die PowerPoint-Dateien in PP2010). Für andere Excel- PowerPointversionen müssen Änderungen vorgenommen werden. Insbesondere beim Dateinamen der Vorlage und in Excel 2003 darf das PowerPoint-Fenster NICHT ausgeblendet bleiben - das führt zu einem Fehler.

Excel - PowerPoint - Textfelder - Diagramm...[ZIP, 200 KB]

Code gehört in ein allgemeines Modul:

Option Explicit
Private Declare Function GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal hwnd As Long, _
    ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
    hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal strBufferLength As Long, ByVal _
    lpBuffer As String) As Long
Private Declare Function GetParent Lib "user32" _
    (ByVal hwnd As Long) As Long
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
Dim blnTMP As Boolean
Const strPPSave As String = "EXCELnachPP" ' anpassen!!! 
Public Sub Test()
    Dim objAppPraes As Object
    Dim blnFrage As Boolean
    Dim intSheet As Integer
    Dim objShape As Object
    Dim objSlide As Object
    Dim objChart As Object
    Dim intTMP As Integer
    Dim objApp As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Set objApp = OffApp("PowerPoint", False)
    If Not objApp Is Nothing Then
        Set objAppPraes = objApp.Presentations.Open _
            (ThisWorkbook.Path & "\" & _
            "TestVorlagePP2010.potx", Untitled:=msoCTrue)
        Call PP_Klein
        With objAppPraes
            For Each objShape In .Slides(.Slides.Count).Shapes
                ' 3 = ppPlaceholderCenterTitle 
                ' 4 = ppPlaceholderSubtitle 
                If objShape.PlaceHolderFormat.Type = 3 Then
                    objShape.TextFrame.TextRange.Text = _
                        Tabelle1.Range("A1").Text
                ElseIf objShape.PlaceHolderFormat.Type = 4 Then
                    objShape.TextFrame.TextRange.Text = _
                        Tabelle1.Range("A2").Text
                End If
            Next objShape
            ' 11 = ppLayoutTitleOnly 
            Select Case MsgBox("Diagramm(e) als eingebettetes Objekt " & _
                """Ja klicken"" oder als Bild ""Nein klicken"" einfügen?", _
                vbYesNo Or vbQuestion Or vbDefaultButton1, "Bild / Objekt?")
                Case vbYes
                    blnFrage = True
                Case vbNo
                    blnFrage = False
            End Select
            For intSheet = 1 To ThisWorkbook.Worksheets.Count
                Set objSlide = .Slides.Add(.Slides.Count + 1, 11)
                .Slides(.Slides.Count).Shapes.Title _
                    .TextFrame.TextRange.Text = _
                        ThisWorkbook.Worksheets(intSheet).Range("B1").Text
                ' 1 = msoShapeRectangle 
                For intTMP = 1 To 9
                    With objSlide.Shapes.AddShape(Type:=1, _
                        Top:=100 + 40 * intTMP, _
                        Left:=60, _
                        Width:=50, _
                        Height:=20)
                        .Name = "Text" & intTMP
                        .Fill.ForeColor.RGB = RGB(223, 223, 223)
                        ' 1 = msoLineSolid 
                        .Line.DashStyle = 1
                        With .TextFrame.TextRange
                            .Text = ThisWorkbook.Worksheets(intSheet) _
                                .Cells(intTMP, 8).Text
                            .Font.Color.RGB = RGB(0, 0, 128)
                            .Font.Name = "Arial"
                            .Font.Size = 12
                        End With
                    End With
                Next intTMP
                If blnFrage = True Then
                    ThisWorkbook.Worksheets(intSheet) _
                        .Shapes("TestChart").Copy
                    Set objChart = objSlide.Shapes.Paste
                Else
                    ThisWorkbook.Worksheets(intSheet) _
                        .Shapes("TestChart").CopyPicture
                    ' 3 = ppPasteMetafilePicture 
                    Set objChart = objSlide.Shapes _
                        .PasteSpecial(DataType:=3)(1)
                End If
                With objChart
                    .Top = 140
                    .Left = 140
                    .Width = 520
                    .Height = 320
                    If blnFrage = True Then
                        .LinkFormat.BreakLink
                    End If
                End With
                Set objSlide = Nothing
            Next intSheet
            .SaveAs ThisWorkbook.Path & "\" & strPPSave
        End With
    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
    Set objSlide = Nothing
    Set objAppPraes = Nothing
    Set objApp = Nothing
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        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
Private Sub PP_Klein()
    Dim hWindow As Long
    hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
    Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
    Dim strTMP As String * 100
    Dim nhWnd As Long
    nhWnd = FindWindow(vbNullString, vbNullString)
    Do While Not nhWnd = 0
        If GetParent(nhWnd) = 0 Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0 Then
                SearchHndByWndName_Parent = nhWnd
                Exit Do
            End If
        End If
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
End Function

Excel - PowerPoint - Textfelder - Diagramm!

2011-02-23T08:12:00.010+01:00

Immer wieder gefragt: Wie bekomme ich einen Bereich bzw. ein Diagramm in eine PowerPoint Datei, die auf einer Vorlage basiert? Für jedes Tabellenblatt soll eine Folie angelegt werden, bestimmte Werte in zu erzeugende Textfelder kopiert werden. Platzhalter bzw. Titel sollen befüllt werden. Dann soll noch das im jeweiligen Tabellenblatt eingebettete Diagramm auf die entsprechende Folie übernommen werden. Erstellt und getestet habe ich das in Excel 2010 (ergo die PowerPoint-Dateien in PP2010). Für andere Excel- PowerPointversionen müssen Änderungen vorgenommen werden. Insbesondere beim Dateinamen der Vorlage und in Excel 2003 darf das PowerPoint-Fenster NICHT ausgeblendet bleiben - das führt zu einem Fehler.

Excel - PowerPoint - Textfelder - Diagramm...[ZIP, 200 KB]

Code gehört in ein allgemeines Modul:

Option Explicit
Private Declare Function GetWindowText Lib "user32" _
    Alias "GetWindowTextA" (ByVal hwnd As Long, _
    ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal _
    hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function GetWindow Lib "user32" _
    (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias _
    "GetTempPathA" (ByVal strBufferLength As Long, ByVal _
    lpBuffer As String) As Long
Private Declare Function GetParent Lib "user32" _
    (ByVal hwnd As Long) As Long
Const GW_HWNDNEXT = 2
Const SW_MINIMIZE = 6
Dim blnTMP As Boolean
Const strPPSave As String = "EXCELnachPP" ' anpassen!!! 
Public Sub Test()
    Dim objAppPraes As Object
    Dim intSheet As Integer
    Dim objShape As Object
    Dim objSlide As Object
    Dim objChart As Object
    Dim intTMP As Integer
    Dim objApp As Object
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Set objApp = OffApp("PowerPoint", False)
    If Not objApp Is Nothing Then
        Set objAppPraes = objApp.Presentations.Open _
            (ThisWorkbook.Path & "\" & _
            "TestVorlagePP2010.potx", Untitled:=msoCTrue)
        Call PP_Klein
        With objAppPraes
            For Each objShape In .Slides(.Slides.Count).Shapes
                ' 3 = ppPlaceholderCenterTitle 
                ' 4 = ppPlaceholderSubtitle 
                If objShape.PlaceHolderFormat.Type = 3 Then
                    objShape.TextFrame.TextRange.Text = _
                        Tabelle1.Range("A1").Text
                ElseIf objShape.PlaceHolderFormat.Type = 4 Then
                    objShape.TextFrame.TextRange.Text = _
                        Tabelle1.Range("A2").Text
                End If
            Next objShape
            ' 11 = ppLayoutTitleOnly 
            For intSheet = 1 To ThisWorkbook.Worksheets.Count
                Set objSlide = .Slides.Add(.Slides.Count + 1, 11)
                .Slides(.Slides.Count).Shapes.Title _
                    .TextFrame.TextRange.Text = _
                        ThisWorkbook.Worksheets(intSheet).Range("B1").Text
                ' 1 = msoShapeRectangle 
                For intTMP = 1 To 9
                    With objSlide.Shapes.AddShape(Type:=1, _
                        Top:=100 + 40 * intTMP, _
                        Left:=60, _
                        Width:=50, _
                        Height:=20)
                        .Name = "Text" & intTMP
                        .Fill.ForeColor.RGB = RGB(223, 223, 223)
                        ' 1 = msoLineSolid 
                        .Line.DashStyle = 1
                        With .TextFrame.TextRange
                            .Text = ThisWorkbook.Worksheets(intSheet) _
                                .Cells(intTMP, 8).Text
                            .Font.Color.RGB = RGB(0, 0, 128)
                            .Font.Name = "Arial"
                            .Font.Size = 12
                        End With
                    End With
                Next intTMP
                ThisWorkbook.Worksheets(intSheet) _
                    .Shapes("TestChart").CopyPicture
                ' 3 = ppPasteMetafilePicture 
                Set objChart = objSlide.Shapes _
                    .PasteSpecial(DataType:=3)(1)
                With objChart
                    .Top = 140
                    .Left = 140
                    .Width = 520
                    .Height = 320
                End With
            Next intSheet
            .SaveAs ThisWorkbook.Path & "\" & strPPSave
        End With
    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
    Set objSlide = Nothing
    Set objAppPraes = Nothing
    Set objApp = Nothing
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        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
Private Sub PP_Klein()
    Dim hWindow As Long
    hWindow = SearchHndByWndName_Parent("Microsoft PowerPoint")
    Call ShowWindow(hWindow, SW_MINIMIZE)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
    Dim strTMP As String * 100
    Dim nhWnd As Long
    nhWnd = FindWindow(vbNullString, vbNullString)
    Do While Not nhWnd = 0
        If GetParent(nhWnd) = 0 Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0 Then
                SearchHndByWndName_Parent = nhWnd
                Exit Do
            End If
        End If
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
End Function

Namen - RefersTo - RefersTo Range - auslesen!

2011-02-08T10:15:00.003+01:00

Frage: In Tabellenblättern ist einer Zelle oder einem Range ein Name zugeordnet. Auf einem neuen Tabellenblatt sollen nun die Werte der Namen und die Zugehörigkeit ausgegeben werden:

Namen - RefersTo - RefersTo Range - auslesen...[ZIP, 50 KB]

Code gehört in ein allgemeines Modul:

Option Explicit
Public Sub Eine_Zelle()
    Dim blnFrage As Boolean
    Dim intCount As Integer
    Dim nmName As Name
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Worksheets.Add After:=Sheets(Sheets.Count)
    For Each nmName In ThisWorkbook.Names
        If LCase(nmName.Name) Like "*nettopreis" Then
            With ActiveSheet
                .Cells(intCount + 1, 1).Value = _
                    nmName.RefersToRange.Text
                .Cells(intCount + 1, 2).Value = _
                    nmName.RefersTo
                .Cells(intCount + 1, 3).Value = _
                    nmName.Name
                intCount = intCount + 1
                blnFrage = True
            End With
        End If
    Next nmName
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    If Not blnFrage Then ActiveSheet.Delete
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub
Public Sub Einen_Range()
    Dim blnFrage As Boolean
    Dim intCount As Integer
    Dim intTMP As Integer
    Dim nmName As Name
    On Error GoTo Fin
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Worksheets.Add After:=Sheets(Sheets.Count)
    For Each nmName In ThisWorkbook.Names
        If LCase(nmName.Name) Like "*netto*" Then
            If nmName.RefersToRange.Count > 1 Then
                For intTMP = 1 To nmName.RefersToRange.Count
                    With ActiveSheet
                        .Cells(intCount + 1, 1).Value = _
                            nmName.RefersToRange.Cells _
                            (intTMP).Value
                        .Cells(intCount + 1, 2).Value = _
                            nmName.RefersTo
                        .Cells(intCount + 1, 3).Value = _
                            nmName.Name
                        intCount = intCount + 1
                        blnFrage = True
                    End With
                Next intTMP
            Else
                With ActiveSheet
                    .Cells(intCount + 1, 1).Value = _
                        nmName.RefersToRange.Text
                    .Cells(intCount + 1, 2).Value = _
                        nmName.RefersTo
                    .Cells(intCount + 1, 3).Value = _
                        nmName.Name
                    intCount = intCount + 1
                    blnFrage = True
                End With
            End If
        End If
    Next nmName
Fin:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
    If Not blnFrage Then ActiveSheet.Delete
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Datei - Zelle auslesen - Dialog!

2011-02-02T08:11:00.005+01:00

Frage: Wie kann man aus einer Datei die über einen Dateiauswahldialog auszuwählen ist eine Zelle in eine Übersicht kopieren. Es soll die Möglichkeit bestehen das Tabellenblatt auszuwählen. Die Zelle wird über eine InputBox das Tabellenblatt über eine UserForm abgefragt.

Datei - Zelle auslesen - Dialog - Tabellenblattauswahl...[ZIP, 80 KB]

Code gehört in "UsrForm1":

Option Explicit
Private Sub UserForm_Activate()
    ComboBox1.ListIndex = 0
End Sub
Private Sub CommandButton1_Click()
    Me.Tag = ComboBox1.Value
    Me.Hide
End Sub

Code gehört in ein allgemeines Modul:

Option Explicit
Public Sub Test()
    Dim wksSheetZ As Worksheet
    Dim wksSheet As Worksheet
    Dim wkbBook As Workbook
    Dim strCell As String
    Dim lngColumn As Long
    Dim strTMP As String
    Dim lngRow As Long
    On Error GoTo Fin:
    lngRow = ActiveCell.Row
    lngColumn = ActiveCell.Column
    strCell = InputBox("Zelle", "Eingabe", "A4")
    If Trim(strCell) = "" Then Exit Sub
    Application.ScreenUpdating = False
    If GetAFile(strTMP) <> "" Then
        ' Tabellenblattname "Gesamt" bei Bedarf anpassen!!!! 
        Set wksSheetZ = ThisWorkbook.Worksheets("Gesamt")
        Set wkbBook = Workbooks.Open(Dir(strTMP))
        For Each wksSheet In wkbBook.Worksheets
            UserForm1.ComboBox1.AddItem (wksSheet.Name)
        Next wksSheet
        UserForm1.Show
        Set wksSheet = wkbBook.Worksheets(UserForm1.Tag)
        With wksSheet
            If .Range(strCell).Value <> "" Then
                .Range(strCell).Copy _
                    wksSheetZ.Cells(lngRow, lngColumn)
                'Oder NUR WERT übertragen!!!! 
                'wksSheetZ.Cells(lngRow, lngColumn) = _
                    .Range(strCell).Value 
            Else
                wksSheetZ.Cells(lngRow, lngColumn).Value = _
                    "Zelle ohne Inhalt!"
            End If
        End With
    Else
        MsgBox "Keine Datei ausgewählt!"
    End If
Fin:
    Application.CutCopyMode = False
    Set wksSheetZ = Nothing
    Set wksSheet = Nothing
    If Not wkbBook Is Nothing Then wkbBook.Close False
    Set wkbBook = Nothing
    Application.ScreenUpdating = True
    Unload UserForm1
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function GetAFile(strFile As String) As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = "C:\"
        .Title = "Datei"
        .ButtonName = "Auswahl..."
        .InitialView = msoFileDialogViewDetails
        If .Show = -1 Then
            strFile = .SelectedItems(1)
        Else
            strFile = ""
        End If
    End With
    GetAFile = strFile
End Function

Hyperlink aus Bilder auslesen!

2011-02-01T07:09:00.003+01:00

Wie kann man Hyperlinks die auf Bilder gelegt sind als Text auslesen? Im folgenden drei Beispiele. Einmal die Ausgabe im "Direkt-Fenster" (STRG+G im VBA-Editor), dann zwei Spalten neben dem Bild und schließlich die Ausgabe in einem anderen Tabellenblatt.

Hyperlink - in Bilder - als Text ausgeben...[ZIP, 150 KB]

Option Explicit
Sub Test_2()
    Dim shpShape As Shape
    For Each shpShape In ThisWorkbook.ActiveSheet.Shapes
        With shpShape
            If .Type = msoPicture Then
                Debug.Print .Hyperlink.Address
                Debug.Print .Name
                Debug.Print .TopLeftCell.Address
            End If
        End With
    Next shpShape
End Sub
Sub Test_1()
    Dim shpShape As Shape
    With ThisWorkbook.ActiveSheet
        For Each shpShape In .Shapes
            If shpShape.Type = msoPicture Then
                .Cells(shpShape.TopLeftCell.Row, _
                    shpShape.TopLeftCell.Column + 2).Value = _
                    shpShape.Hyperlink.Address
            End If
        Next shpShape
    End With
End Sub
Sub Test()
    Dim varArr() As String
    Dim shpShape As Shape
    Dim lngTMP As Long
    Redim varArr(1 To Tabelle1.Shapes.Count)
    ' eventuell anpasen!!! 
    For Each shpShape In Tabelle1.Shapes
        With shpShape
            If .Type = msoPicture Then
                ' später auskommentieren 
                Debug.Print .Hyperlink.Address
                ' später auskommentieren 
                Debug.Print .Name
                ' später auskommentieren 
                Debug.Print .TopLeftCell.Address
                varArr(lngTMP + 1) = .Hyperlink.Address
                lngTMP = lngTMP + 1
            End If
        End With
    Next shpShape
    Tabelle2.Range("A1").Resize(Ubound(varArr)) = _
        WorksheetFunction.Transpose(varArr)
End Sub
' Tabelle1 UND Tabelle2 sind die Codenamen der Tabellenblätter 
' Siehe auch VBA-Editor Name VOR der Klammer 
' z. B. Tabelle1 (Tabelle1) bei neuer Datei und deutschem Excel 
' Debug.Print ist nur zum testen drin - kann dann auskommentiert 
' bzw. gelöscht werden