bestimmten Abschnitt aus vielen Dateien auslesen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Selma,
probier mal diesen Code. Er listet die Dateinamen in der aktiven Tabelle in Spalte "A" auf.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub SearchHTML()
Dim strDir As String, strFile As String, strTmp As String, strRes As String
Dim vRes() As Variant, a As Variant
Dim result As Long, lngI As Long

strDir = "F:\Temp" 'zu untersuchendes Verzeichnis - Anpassen!

Columns(1).ClearContents

result = FileSearchFSO(a, strDir, "*.html", False) 'letzter Parameter TRUE wenn Unterordner durchsucht werden sollen!

If result <> 0 Then

    Redim vRes(0)

    For lngI = 0 To result - 1

        strFile = a(lngI)

        Open strFile For Input As #1

        Do While Not EOF(1)

            Line Input #1, strTmp

            If strTmp Like "*.cel*" Then
                strRes = Mid(strTmp, InStr(1, strTmp, "<a href=") + 9)
                strRes = Mid(strRes, 1, InStr(1, strRes, ".cel") + 3)
                vRes(UBound(vRes)) = strRes
                Redim Preserve vRes(UBound(vRes) + 1)
            End If

        Loop

        Close #1

    Next

End If

If UBound(vRes) > 0 Then
    Redim Preserve vRes(UBound(vRes) - 1)
    Range("A1:A" & UBound(vRes) + 1) = Application.Transpose(vRes)
    Columns(1).AutoFit
End If

End Sub

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

Hallo Selma,
mit Ordnerauswahl und die neuen Daten werden unten angehängt.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub SearchHTML()
Dim strDir As String, strFile As String, strTmp As String, strRes As String
Dim vRes() As Variant, a As Variant
Dim result As Long, lngI As Long, lngStart

strDir = fncBrowseForFolder("C:\")

If strDir = "" Then Exit Sub

lngStart = Cells(Rows.Count, 1).End(xlUp).Row + 1

result = FileSearchFSO(a, strDir, "*.html", False) 'letzter Parameter TRUE wenn Unterordner durchsucht werden sollen!

If result <> 0 Then

    Redim vRes(0)

    For lngI = 0 To result - 1

        strFile = a(lngI)

        Open strFile For Input As #1

        Do While Not EOF(1)

            Line Input #1, strTmp

            If strTmp Like "*.cel*" Then
                strRes = Mid(strTmp, InStr(1, strTmp, "<a href=") + 9)
                strRes = Mid(strRes, 1, InStr(1, strRes, ".cel") + 3)
                vRes(UBound(vRes)) = strRes
                Redim Preserve vRes(UBound(vRes) + 1)
            End If

        Loop

        Close #1

    Next

End If

If UBound(vRes) > 0 Then
    Redim Preserve vRes(UBound(vRes) - 1)
    Range(Cells(lngStart, 1), Cells(UBound(vRes) + lngStart, 1)) = Application.Transpose(vRes)
    Columns(1).AutoFit
End If

End Sub

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

Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object

Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)

If objFlder Is Nothing Then GoTo ErrExit

Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path

ErrExit:

Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

bestimmten Abschnitt aus vielen Dateien auslesen?

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread