Sub 按钮2_Click()
Set fso = CreateObject("scripting.filesystemobject")
fd_x = ""
arr = Range("d2:d" & Cells(Rows.Count, "d").End(3).Row + 1)
Application.ScreenUpdating = False
str1 = ThisWorkbook.Path & "\合并文件夹\"
Call get_folder(fd_x)
Call Getfd(fd_x, arr, str1, fso)
Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth, arr, str1, fso)
Set ff = fso.getfolder(pth)
If InStr(ff, "合并文件夹") = 0 Then
For Each f In ff.Files
For k = 1 To UBound(arr)
If InStr(f.Name, arr(k, 1)) > 0 And Len(arr(k, 1)) > 0 Then
fso.CopyFile f, str1, True
fso.DeleteFile f, True
Exit For
End If
Next k
Next f
End If
For Each fd In ff.subfolders
Call Getfd(fd, arr, str1, fso)
Next fd
End Sub
Sub get_folder(fd_x)
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.Title = "请选择对应文本夹"
If .Show Then
fd_x = .SelectedItems(1)
Else
MsgBox "未选择有效文件夹"
End
End If
End With
End Sub