Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
944to948
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
944to948
944to948
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Inhaltsverzeichnis

Inhaltsverzeichnis
24.01.2008 21:44:08
Peter

Hallo,
ich habe folgendes Problem:
Ich möchte ein Inhaltsverzeichnis aller Excel-Dateien in einem Bestimmten Verzeichnis erstellen.
Aus Tabelle1:
In Spalte A soll der jeweilige Hyperlink mit Text des Dateinamens.
In Spalte B der Wert aus Zelle H5
In Spalte C der Letzte Wert aus dem Bereich D13:D32
Aus Tabelle2:
Wenn im Bereich G11:40 ein "x" dann "Fehler" In Spalte D
Randbedingungen:
Wenn möglich sollten Dateien zur Abfrage nicht geöffnet werden.
Die Dateinamen sind: von M_000 bis M_200
Tabelle 1: Kartei_000 bis Kartei_200
Tabelle 2: Protokoll_000 bis Protokoll_200
Gruß Peter

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Inhaltsverzeichnis
24.01.2008 22:51:48
Josef Ehrensberger
Hallo Peter,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Datei_Und_Daten()
Dim strPath As String, strF As String, strG As String, strM As String
Dim result As Long, l As Long, r As Long, a

On Error GoTo ErrExit
Application.ScreenUpdating = False

strPath = "F:\Temp" 'Verzeichnis - Anpassen!

result = FileSearchFSO(a, strPath, "*.xls*", True)
'letzter Parameter FALSE wenn Unterordner nicht durchsucht werden sollen!

r = 2 'Erste Zeile in die Daten eingetragen werden!

With Sheets("Tabelle1") 'Tabelle in die geschrieben wird, Name anpassen!
    
    .Range(.Cells(r, 1), .Cells(Rows.Count, 4)).ClearContents
    
    If result > 0 Then
        For l = 0 To UBound(a)
            strG = Replace(a(l), strPath, "")
            If Left(strG, 1) = "\" Then strG = Right(strG, Len(strG) - 1)
            strF = Left(strG, InStrRev(strG, ".") - 1)
            If strF Like "M_###" Then
                
                .Cells(r, 1) = a(l)
                
                .Hyperlinks.Add Anchor:=.Cells(r, 1), _
                    Address:=a(l), _
                    SubAddress:="", _
                    TextToDisplay:=strG
                
                strM = "'" & strPath & "\[" & strG & "]Kartei_" & Right(strF, 3) & "'!"
                
                .Cells(r, 2).Formula = "=" & strM & "$H$5"
                
                .Cells(r, 3).FormulaLocal = _
                    "=VERWEIS(2;1/(" & strM & "$D$13:$D$32);" & strM & "$D$13:$D$32)"
                
                strM = "'" & strPath & "\[" & strG & "]Protokoll_" & Right(strF, 3) & "'!"
                
                .Cells(r, 4).FormulaLocal = _
                    "=WENN(SUMMENPRODUKT((" & strM & "$G$11:$G$40=""x"")*1)>0;""Fehler"";"""")"
                
                .Range(.Cells(r, 2), .Cells(r, 4)).Value = _
                    .Range(.Cells(r, 2), .Cells(r, 4)).Value
                
                r = r + 1
                
            End If
        Next
    End If
    .Columns.AutoFit
End With

ErrExit:
Application.ScreenUpdating = True

If Err.Number > 0 Then
    MsgBox Err.Number & vbLf & Err.Description, vbExclamation, "Fehler"
End If
End Sub

'by J.Ehrensberger
Private Function FileSearchFSO(ByRef Files As Variant, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
    Optional ByVal SubFolders As Boolean = False) As Long


Dim mobjFSO As Object, mfsoFolder As Object, mfsoSubFolder As Object, mfsoFile As Object

Set mobjFSO = CreateObject("Scripting.FileSystemObject")

Set mfsoFolder = mobjFSO.GetFolder(InitialPath)

On Error Resume Next

For Each mfsoFile In mfsoFolder.Files
    If Not mfsoFile Is Nothing Then
        If LCase(mobjFSO.GetFileName(mfsoFile)) Like LCase(FileName) Then
            If IsArray(Files) Then
                Redim Preserve Files(UBound(Files) + 1)
            Else
                Redim Files(0)
            End If
            Files(UBound(Files)) = mfsoFile
        End If
    End If
Next

If SubFolders Then
    For Each mfsoSubFolder In mfsoFolder.SubFolders
        FileSearchFSO Files, mfsoSubFolder, FileName, SubFolders
    Next
End If

If IsArray(Files) Then FileSearchFSO = UBound(Files) + 1
On Error GoTo 0
Set mobjFSO = Nothing
Set mfsoFolder = Nothing
End Function

Gruß Sepp

Anzeige
AW: Inhaltsverzeichnis
25.01.2008 14:24:28
Peter
Hallo Sepp,
vielen Dank. Funktioniert prima!!!
Gruß Peter

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige