Question

如何修改代码，以便查询文件夹（文件所在的位置）以及子文件夹？目前，仅读取文件所在的文件夹。我想用True或False激活此功能（例如AllSubfolders）。此外，还有一种通过指定不同路径来查询某些子文件夹的方法（为此，我会将AllSubfolders函数设置为false）。

不幸的是，经过几次尝试，我并没有取得成功。我的VBA知识不好。

我尝试用我的代码实现以下代码：

Dim FileSystem As Object
Dim HostFolder As String

HostFolder = "C:\Users\admin\Desktop\Dokumente\"

Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)

Sub DoFolder(Folder)
    Dim SubFolder
    For Each SubFolder In Folder.SubFolders
        DoFolder SubFolder
    Next
    Dim File
    For Each File In Folder.Files
        ' Operate on each file
    Next
End Sub

但没有成功。使用以下代码，我可以从“活动工作簿”文件夹中的多个文件中复制数据。我想为搜索子文件夹设置True或False，并提供从中复制数据的特定路径。

Sub Copy_Data_from_Files_in_Folder()

ActiveSheet.Range("A4:I1000").ClearContents 'Vorgegebenen Tabelleninhalt vor dem Kopieren der Daten löschen

Dim StatusCalc

'Makrobremsen lösen - Am Beginn eines Makros
With Application
    .EnableEvents = False
    StatusCalc = .Application.Calculation 'Aktuellen Berechnungsmodus merken
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With

'Const sXlsPath = "C:\Users\admin\Desktop\Dokumente\" 'Pfad zu bestimmtem Ordner

'oder wenn sich die Dateien im selben Ordner befinden

sXlsPath = ThisWorkbook.Path 'Datei im gleichen Ordner wie Auswertungsdateien

Const iStartZeile = 4 'Angeben, ab welcher Zeile eingefügt werden soll
Const iStartSpalte = 1 'Angeben, ab welcher Spalte eingefügt werden soll
Const Zellen = "D3,K3,K7,H34,R3,D5,K5,R5,A29" 'Angeben, welche Zellen kopiert werden sollen

Dim oFso As Object, oFile As Object, oWkb1 As Workbook, oWks0 As Worksheet, oWks1 As Worksheet
Dim aCells As Variant, iNextLine As Long, i As Integer

Set oWks0 = ThisWorkbook.ActiveSheet

aCells = Split(Zellen, ","):  iNextLine = iStartZeile

Set oFso = CreateObject("Scripting.FilesystemObject")

For Each oFile In oFso.GetFolder(sXlsPath).Files
    If LCase(oFso.GetExtensionName(oFile.Name)) = "xlsx" Then 'Hier den Dateityp anpassen
        If ThisWorkbook.Path <> oFile.Name Then
            Set oWkb1 = Workbooks.Open(oFile.Path)
            Set oWks1 = oWkb1.Sheets(1)
            For i = 0 To UBound(aCells)
                oWks0.Cells(iNextLine, iStartSpalte).Offset(0, i) = oWks1.Range(Trim(aCells(i))).Value
            Next
            oWkb1.Close False
            iNextLine = iNextLine + 1
        End If
    End If
Next

Beenden: 'Sprungadresse zum Beenden diese Makros
'Makrobremsen zurücksetzen - vor dem Beenden eines Makros
  With Application
    .EnableEvents = True
    .Calculation = StatusCalc
    .ScreenUpdating = True
  End With

End Sub

使用VBA遍历定义的子文件夹

0 个答案: