Question

我正在创建一个爬行到子文件夹并检索某些文件名称的宏。我使用来自this的代码回答另一个问题并且工作正常以将结果导入到即时窗口中，但我想将它们作为列表放入单元格中。我得到的只是第一次迭代的结果。

我想做的事情可能是显而易见的，但我发誓我试过并且自己找不到答案。为了记录，我刚开始编码。

我的代码在这里。最重要的部分出现在Sub ListFiles（fld As Object，Mask As String）。

Option Explicit

Sub Retrieve_Info()

Dim strPath As Variant
Dim pasta_destino As Range
Dim fle As String
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String

Set pasta_destino = ThisWorkbook.Worksheets("VINCULATOR").Range("pasta_destino")
strPath = Application.GetOpenFilename _
(Title:="Selecione o arquivo.xlsx", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")

If Not strPath = False Then
pasta_destino = strPath
fle = Dir(strPath)

Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)

Set fldStart = fso.GetFolder(Replace(strPath, fle, ""))
Mask = "*.xlsx"
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
Next
End If
End Sub

Sub ListFiles(fld As Object, Mask As String)
    Dim fl As Object 'File
    Dim vrow As Integer
    Dim vinculadas As Range
    Dim n_vinc As Range
    Set vinculadas = ThisWorkbook.Worksheets("VINCULATOR").Range("vinculadas")
    Set n_vinc = ThisWorkbook.Worksheets("VINCULATOR").Range("n_vinc")
    vrow = 0
    For Each fl In fld.Files
       If fl.Name Like Mask And InStr(fl.Name, "completo") = 0 Then
       vrow = vrow + 1
            vinculadas.Cells(vrow, 1) = fld.Path & "\" & fl.Name
        End If
    Next
   n_vinc = vrow
End Sub

请帮忙！

Answer 1

我采取了稍微不同的方法，除了执行速度更快之外，您可能更容易遵循。请试试这个。

Sub SpecifyFolder()
    ' 10 Dec 2017

    Dim Fd As FileDialog
    Dim PathName As String
    Dim Fso As Object
    Dim Fold As Object, SubFold As Object
    Dim i As Long

    Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
    With Fd
        .ButtonName = "Select"
        .InitialView = msoFileDialogViewList
        .InitialFileName = "C:\My Documents\"       ' set as required
        .Show

        If .SelectedItems.Count Then
            PathName = .SelectedItems(1)
        Else
            Exit Sub                                ' user cancelled
        End If
    End With
    Set Fd = Nothing

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Fold = Fso.GetFolder(PathName)
    ListFiles Fold, "*.xlsx"
    For Each SubFold In Fold.SubFolders
            ListFiles SubFold, "*.xlsx"
    Next SubFold
    Set Fso = Nothing
End Sub

Sub ListFiles(Fold As Object, _
              Mask As String)
    ' 10 Dec 2017

    Dim Fun() As String                             ' file list
    Dim Rng As Range
    Dim Fn As String                                ' file name
    Dim i As Long                                   ' array index

    ReDim Fun(1 To 1000)                            ' maximum number of expected files in one folder
    Fn = Dir(Fold.Path & "\")
    Do While Len(Fn)
        If Fn Like Mask And InStr(Fn, "completo") = 0 Then
            i = i + 1
            Fun(i) = Fold.Path & "\" & Fn
        End If
        Fn = Dir
    Loop

    If i Then
        ReDim Preserve Fun(1 To i)
        With ThisWorkbook.Worksheets("VINCULATOR")
            ' specify the column in which to write (here "C")
            i = .Cells(.Rows.Count, "C").End(xlUp).Row
            Set Rng = .Cells(i + 1, "C").Resize(UBound(Fun), 1)
            Application.ScreenUpdating = False
            Rng.Value = Application.Transpose(Fun)
            Application.ScreenUpdating = True
        End With
    End If
End Sub

如您所见，我已经省去了指定目标范围，只有工作表和列（我选择了C列;请根据ListFiles子要求进行更改）。请注意，代码会将新列表附加到指定列的现有内容。

代码没有两件事让我完全满意。一，它不会写入空列C的第一行。而是将第一行留空。你可能真的喜欢这样。二，它不做子子文件夹。仅从所选文件夹及其直接子文件夹中提取文件名。如果需要，任何附加功能都需要额外的编程。

最后，我承认我没有测试将列表正确传输到工作表。我认为它可以正常工作，但您应该检查工作表列中是否列出了名字和姓氏。它们是从文件夹中提取的，但是在写入工作表时可能会忽略它们，这是在这种特殊方法中发生的典型错误。

VBA Excel：每个结果进入细胞？柜台不工作？

1 个答案: