列出excel

Question

我试图创建一个文档寄存器，最后列出所选文件夹和所有子文件夹中的某些文件，目前我的代码位于下面，列出了文件及其路径。虽然我无法考虑我需要添加到此代码中以获取Excel工作表来创建一个列，其中列出了文件类型＆＃34; PDF＆＃34;，＆＃34; TXT＆＃34;，DWG＆ ＃34;然后是另一列使用预定义列表来显示这些文件的类型（即pdf = document，DWG = CAD file等）。

接下来要添加的是从路径列生成的超链接。

最后有一种方法可以让excel忽略以前收集的数据，因为将从中收集数据的文件夹定期更新，我希望能够只运行VBA，这样就会忽略子文件夹这已经从中提取数据了。

非常感谢任何帮助。

Option Explicit
'the first row with data
Const ROW_FIRST As Integer = 5

'This is an event handler. It exectues when the user
'presses the run button
Private Sub btnGet_Click()
'determines if the user selects a directory
'from the folder dialog
Dim intResult As Integer
'the path selected by the user from the
'folder dialog 
Dim strPath As String
'Filesystem object
Dim objFSO As Object
'the current number of rows
Dim intCountRows As Integer
Application.FileDialog(msoFileDialogFolderPicker).Title = _
"Select a Path" 
'the dialog is displayed to the user
intResult = Application.FileDialog( _
msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog
If intResult <> 0 Then
strPath = Application.FileDialog(msoFileDialogFolderPicker _
).SelectedItems(1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")

'loops through each file in the directory and prints their
'names and path
intCountRows = GetAllFiles(strPath, ROW_FIRST, objFSO)
'loops through all the files and folder in the input path
Call GetAllFolders(strPath, objFSO, intCountRows)   
End If
End Sub

'''
'This function prints the name and path of all the files
'in the directory strPath
'strPath: The path to get the list of files from
'intRow: The current row to start printing the file names
'in
'objFSO: A Scripting.FileSystem object.

Private Function GetAllFiles(ByVal strPath As String, _
ByVal intRow As Integer, ByRef objFSO As Object) As Integer
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
i = intRow - ROW_FIRST + 1
Set objFolder = objFSO.GetFolder(strPath)
For Each objFile In objFolder.Files
    'print file name
    Cells(i + ROW_FIRST - 1, 1) = objFile.Name
    'print file path
    Cells(i + ROW_FIRST - 1, 2) = objFile.Path
    i = i + 1
Next objFile
GetAllFiles = i + ROW_FIRST - 1
End Function

'''
'This function loops through all the folders in the
'input path. It makes a call to the GetAllFiles
'function. It also makes a recursive call to itself
'strFolder: The folder to loop through
'objFSO: A Scripting.FileSystem object
'intRow: The current row to print the file data on
Private Sub GetAllFolders(ByVal strFolder As String, _
ByRef objFSO As Object, ByRef intRow As Integer)
Dim objFolder As Object
Dim objSubFolder As Object

'Get the folder object
Set objFolder = objFSO.GetFolder(strFolder)
'loops through each file in the directory and
'prints their names and path
For Each objSubFolder In objFolder.subfolders
intRow = GetAllFiles(objSubFolder.Path, _
    intRow, objFSO)
'recursive call to to itsself
Call GetAllFolders(objSubFolder.Path, _
    objFSO, intRow)
Next objSubFolder
End Sub

Answer 1

解决方案：在Function GetAllFiles中进行以下更改 - 这对我有用：

在Dim i As Integer之后，添加：

Dim Extension As String

在Cells(i + ROW_FIRST - 1, 2) = objFile.Path之后，添加：

Extension = Right(objFile.Path, Len(objFile.Path) - InStrRev(objFile.Path, "."))
Cells(i + ROW_FIRST - 1, 3) = Extension
Cells(i + ROW_FIRST - 1, 4) = objFile.Type
Cells(i + ROW_FIRST - 1, 5).Formula = "=HYPERLINK(""" & objFile.Path & """,""Link"")"

说明：Extension变量通过在文件名中查找点.来填充，并且只使用点的右侧。然后将其添加到下一列。该扩展名的描述取自文件对象的Type属性。最后，最右边的列填充了指向文件及其路径的=HYPERLINK函数。

编辑：在提示@TimWilliams之后编辑（谢谢！），我简化了上面的代码。 如果您需要自定义文件类型说明，请改用以下方法并替换

Cells(i + ROW_FIRST - 1, 4) = objFile.Type

与

On Error Resume Next
Cells(i + ROW_FIRST - 1, 4) = Application.WorksheetFunction.VLookup(Extension, _
    ActiveWorkbook.Sheets("filetypes").Range("A:B"), 2, False)

在运行此功能之前，您需要添加一个名为 filetypes 的工作表，并将最常见的扩展名放在A列中，将其长文本/说明放入B列：

要获得类似的列表而不需要太多工作，您可以复制找到的内容on this website，然后使用搜索＆amp;删除点.。替换功能。