列出我的目錄中的所有文件夾visual basic

Question

我想通過觸摸按鈕將所有文件夾從目錄中的驅動器列出到Excel電子表格中。我做了按鈕，並分配了這個宏...爲什麼不編譯？ *** ****顯示他們調試的內容。所述對象文件夾不是對象。請幫忙！

Sub ListAllFile() 

Dim objFSO As Object 
Dim objFolder As Object 
Dim objFile As Object 
Dim ws As Worksheet 

Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set ws = Worksheets.Add 

'Get the folder object associated with the directory 

***Set objFolder = fso.GetFolder("C:hello\EMILY")*** 
ws.Cells(1, 1).Value = objFolder.Name 

'Loop through the Files collection 
For Each objFile In objFolder.Files 
    ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name 
Next 


End Sub 

Answer 1

這將允許您獲取文件夾名稱，除非您確實需要文件。它從您的原始代碼進行了修改。我評論了excel /工作表邏輯。

問題的一部分是fso.GetFolder不是一個被聲明和設置的對象。如果您還想要文件，可以將objFolder.Subfolders更改爲。文件

Sub ListAllFile() 

Dim objFSO As Object 
Dim objFolder As Object 
Dim objFile As Object 
Dim ws As Worksheet 

Set objFSO = CreateObject("Scripting.FileSystemObject") 
'Set ws = Worksheets.Add 

'Get the folder object associated with the directory 

Set objFolder = objFSO.GetFolder("C:\users") 
'ws.Cells(1, 1).Value = objFolder.Name 

'Loop through the Files collection 
For Each objFile In objFolder.subfolders 
MsgBox objFile.Name ' to test output 
'ws.Cells(ws.UsedRange.Rows.Count + 1, 1).Value = objFile.Name 
Next 


End Sub 

Answer 2

有很多方法可以做到這一點。這是一種方法。

Option Explicit 
Sub FileListingAllFolder() 

Dim pPath As String 
Dim FlNm As Variant 
Dim ListFNm As New Collection ' create a collection of filenames 

Dim OWb As Workbook 
Dim ShtCnt As Integer 
Dim Sht As Integer 

Dim MWb As Workbook 
Dim MWs As Worksheet 
Dim i As Integer 

' Open folder selection 
With Application.FileDialog(msoFileDialogFolderPicker) 
    .Title = "Select a Folder" 
    .AllowMultiSelect = False 
    If .Show <> -1 Then GoTo NextCode 
    pPath = .SelectedItems(1) 
End With 

Application.WindowState = xlMinimized 
Application.ScreenUpdating = False 

' Create master workbook with single sheets 
Set MWb = Workbooks.Add(1) 
MWb.Sheets(1).Name = "Result" 
Set MWs = MWb.Sheets("Result") 
Cells(1, 1) = "No." 
Cells(1, 2) = "Sheet Name" 
Cells(1, 3) = "File Name" 
Cells(1, 4) = "Link" 
i = 2 

' Filling a collection of filenames (search Excel files including subdirectories) 
Call FlSrch(ListFNm, pPath, "*.xls", True) 

' Print list to immediate debug window and as a message window 
For Each FlNm In ListFNm ' cycle for list(collection) processing 

    'Start Processing here 
    Set OWb = Workbooks.Open(FlNm) 
    ShtCnt = ActiveWorkbook.Sheets.Count 
    For Sht = 1 To ShtCnt 
     MWs.Cells(i, 1) = i - 1 
     MWs.Cells(i, 2) = Sheets(Sht).Name 
     MWs.Cells(i, 3) = OWb.Name 
     MWs.Cells(i, 4).Formula = "=HYPERLINK(""" & FlNm & """,""Click Here"")" 
     i = i + 1 
    Next Sht 
    'End file processing file 
    OWb.Close False 
Next FlNm 

' Print to immediate debug window and message if no file was found 
If ListFNm.Count = 0 Then 
    Debug.Print "No file was found !" 
    MsgBox "No file was found !" 
    MWb.Close False 
    End 
End If 

MWb.Activate 
MWs.Activate 
Cells.Select 
Selection.EntireColumn.AutoFit 
Range("A1").Select 
Application.ScreenUpdating = True 
Application.WindowState = xlMaximized 

End 

NextCode: 
MsgBox "You Click Cancel, and no folder selected!" 

End Sub 

Private Sub FlSrch(pFnd As Collection, pPath As String, pMask As String, pSbDir As Boolean) 

Dim flDir As String 
Dim CldItm As Variant 
Dim sCldItm As New Collection 

' Add backslash at the end of path if not present 
pPath = Trim(pPath) 
If Right(pPath, 1) <> "\" Then pPath = pPath & "\" 

' Searching files accordant with mask 
flDir = Dir(pPath & pMask) 
    Do While flDir <> "" 
     pFnd.Add pPath & flDir 'add file name to list(collection) 
     flDir = Dir ' next file 
    Loop 

' Procedure exiting if searching in subdirectories isn't enabled 
If Not pSbDir Then Exit Sub 

' Searching for subdirectories in path 
flDir = Dir(pPath & "*", vbDirectory) 
    Do While flDir <> "" 

     ' Add subdirectory to local list(collection) of subdirectories in path 
     If flDir <> "." And flDir <> ".." Then If ((GetAttr(pPath & flDir) And _ 
     vbDirectory) = 16) Then sCldItm.Add pPath & flDir 
     flDir = Dir 'next file 
    Loop 

' Subdirectories list(collection) processing 
For Each CldItm In sCldItm 
    Call FlSrch(pFnd, CStr(CldItm), pMask, pSbDir) ' Recursive procedure call 
Next 

End Sub 

另外，請查看下面的鏈接。

http://www.learnexcelmacro.com/wp/download/

保存從 '文件管理器（Excel工作簿）' 命名的鏈接文件。這是一個非常酷的應用程序！