Inhaltsverzeichnis

Forumthread: 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

AW: Inhaltsverzeichnis

24.01.2008 22:51:48

Josef Ehrensberger
AW: Inhaltsverzeichnis

25.01.2008 14:24:28

Peter

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

AW: Inhaltsverzeichnis

25.01.2008 14:24:28

Peter

Hallo Sepp,
vielen Dank. Funktioniert prima!!!
Gruß Peter

Beliebteste Forumthreads (12 Monate)

Forumthread: Inhaltsverzeichnis

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

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread