VBA、FSO、不遍历docx问题的解决

Question

问题遇到的现象和发生背景：

使用VBA-FSO对象方法遍历文件夹及子文件夹的部分内容并复制到当前文件夹，问题有如下：①代码：Set w1 = Workbooks.Open(files.Path)，遇到docx的内容时，报错显示格式无效，请问如何调整，只用遍历xlsx格式，不需要docx格式进行遍历；②遍历的文件老是要自动弹出，如何设置调整新增代码避免手工弹出。

写的代码如下：ub 所有文件夹()
Dim fs As New FileSystemObject, arr(), i, j, k, wb, g, test
Dim fd, subfd As Folder
Dim files As file
Set fp = Application.FileDialog(msoFileDialogFolderPicker) '选择需要查询文件的文件夹
fp.Show
Set paths = fp.SelectedItems
ReDim arr(1)
arr(0) = paths(1) '文件夹路径赋给数组
Application.ScreenUpdating = False
Do Until i > k
Set fd = fs.GetFolder(arr(i))
For Each files In fd.files
j = j + 1

    'Range("a" & j + 1).Hyperlinks.Add Anchor:=Range("a" & j + 1), Address:=files.Path, TextToDisplay:=files.Name
    Set w1 = Workbooks.Open(files.Path)
    'Range("b" & j + 1) = files.DateLastModified
    'Range("C" & j + 1) = files.Size \ 1024 & "KB"
    g = w1.Sheets(1).Range("a1048576").End(xlUp).Row
    w1.Sheets(1).Range("D1：D1" & g).Copy Destination:=ThisWorkbook.Sheets(1).Range("a1048576").End(xlUp).Offset(1, 0)
    w1.Close

    
Next
For Each subfd In fd.SubFolders
    k = k + 1
    ReDim Preserve arr(k + 1)
    arr(k) = subfd  '将子文件夹赋给数组
Next
i = i + 1

Loop
MsgBox ("一共有" & j & "个文件，" & k & "个文件夹")
Application.ScreenUpdating = True
End Sub

Answer 1

Sub 所有文件夹()
    Dim fs As New FileSystemObject, arr(), i, j, k, wb, g, test
    Dim fd, subfd As Folder
    Dim files As file
    Set fp = Application.FileDialog(msoFileDialogFolderPicker) '选择需要查询文件的文件夹
    fp.Show
    Set paths = fp.SelectedItems
    ReDim arr(1)
    arr(0) = paths(1) '文件夹路径赋给数组
    Application.ScreenUpdating = False
    Do Until i > k
        Set fd = fs.GetFolder(arr(i))
        For Each file In fd.files
            If LCase(Right(file.Name, 5)) = ".xlsx" Then '限制为xlsx扩展名的文件
                j = j + 1
                Set w1 = Workbooks.Open(file.Path)
                g = w1.Sheets(1).Range("a1048576").End(xlUp).Row
                w1.Sheets(1).Range("D1:D1" & g).Copy Destination:=ThisWorkbook.Sheets(1).Range("a1048576").End(xlUp).Offset(1, 0)
                w1.Close False  '退出时不保存
            End If
        Next
        For Each subfd In fd.SubFolders
            k = k + 1
            ReDim Preserve arr(k + 1)
            arr(k) = subfd  '将子文件夹赋给数组
        Next
        i = i + 1
    Loop
    MsgBox ("一共有" & j & "个文件，" & k & "个文件夹")
    Application.ScreenUpdating = True
End Sub