VBA - 复制为路径

Question

我需要有关我以前从未遇到过的编码要求的帮助。我刚刚浏览了几年前在这里提出的类似问题 - VBA to Copy files using complete path and file names listed in Excel Object。 我的问题类似，但比 OP 简单一些。

我有许多文件夹，每个文件夹包含大约 100 个小 .csv 文件；对于每个文件夹，我需要将每个文件的路径复制到打开的工作表中。 .csv 文件的每个文件夹都有自己的关联工作簿。

例如，打开的工作簿是F:\SM\M400AD.xlsm，活动的工作表是CSV_List。包含 .csv 文件的文件夹是 F:\SM\M400AD。 手动操作，我的顺序是：

打开文件夹F:\SM\M400AD

全选

复制路径

粘贴到工作表CSV_List的Range("B11")

当我手动执行时，如上所述，我得到一个如下所示的列表：

"F:\SM\M400AD\AC1.csv"
"F:\SM\M400AD\AC2.csv"
"F:\SM\M400AD\AE.csv"
"F:\SM\M400AD\AF.csv"
"F:\SM\M400AD\AG.csv"
"F:\SM\M400AD\AH1.csv"
"F:\SM\M400AD\AH2.csv"
"F:\SM\M400AD\AJ.csv"

在页面下方，直到我有 100 条路径的列表。然后将此单列列表粘贴到工作表CSV_List 中，从Range("B11") 开始。

我需要自动执行此操作，如果 VBA 大师可以为我编写此代码，我将不胜感激。

Answer 1

之前有人问过这样的问题，例如：

Loop through files in a folder using VBA?
List files in folder and subfolder with path to .txt file

不同之处在于您要“自动化”它，这意味着您要在工作簿Open 事件上执行代码。

如何实现？

1. 打开F:\SM\M400AD.xlsm文件。
2. 转到代码窗格 (ALT+F11)

3. 插入新模块并复制以下代码

   Option Explicit
   
   Sub EnumCsVFilesInCurrentFolder()
   
       Dim sPath As String, sFileName As String
       Dim i As Integer
   
       sPath = ThisWorkbook.Path & "\"
       i = 11
       Do
           If Len(sFileName) = 0 Then GoTo SkipNext
           If LCase(Right(sFileName, 4)) = ".csv" Then
               'replcae 1 with proper sheet name!
               ThisWorkbook.Worksheets(1).Range("B" & i) = sPath & sFileName
               i = i + 1
           End If
   
   SkipNext:
           sFileName = Dir(sPath)
       Loop While sFileName <> ""
   
   End Sub
   

4. 现在，转到ThisWorkbook 模块并插入以下程序：

   Private Sub Workbook_Open()
       EnumCsVFilesInCurrentFolder
   End Sub
   

5. 保存并关闭工作簿

工作簿可以使用了。每当你打开它，EnumCsVFilesInCurrentFolder 宏就会被执行。

注意：您必须更改上述代码以限制记录数。