VBA Excel：將每個結果放入單元格嗎？ 櫃台不工作？

Question

我正在創建一個宏，該宏會爬入子文件夾並檢索某些文件的名稱。 我使用了此答案中另一個問題的代碼，並且可以很好地將結果放入即時窗口中，但是我想將它們作為列表放入單元格中。 我得到的只是第一次迭代的結果。

我想做的事情可能很明顯，但是我發誓我嘗試過並且自己找不到答案。 作為記錄，我只是開始編寫代碼。

我的代碼在這里。 重要的部分在子ListFiles（fld作為對象，Mask作為字符串）的最后。

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的第一行。相反，它將第一行留空。 您實際上可能會喜歡。 第二，它不做子子文件夾。 文件名僅從所選文件夾及其直接子文件夾中提取。 如果需要，則任一附加功能都需要附加編程。

最后，我承認我沒有測試列表是否正確傳輸到工作表。 我認為它可以正常工作，但是您應該檢查工作表列中是否列出了姓氏和名字。 它們是從文件夾中提取出來的，但是在寫入工作表時忽略它們可能是在此特定方法中發生的典型錯誤。