如何将符合条件的文件夹剪切至另一个文件夹中?

1042271867

如何将符合条件的文件夹剪切至另一个文件夹中?批量将附件中“原来文件夹”里的文件夹名 等于 表中A列的文件夹（包括本文件里面的内容）剪切到“结果”这个文件夹中？实际上有很文件夹需要操作。谢谢老师！

fzxba

Sub MoveFolders()  'AI结果，纯好玩，测试一下，灌水帖
    ' 设置初始路径和目标路径
    Dim sourcePath As String
    Dim targetPath As String
    sourcePath = "C:\SourceFolder\"
    targetPath = "C:\TargetFolder\"
   
    ' 设置条件，判断要剪切的文件夹是否符合要求
    Dim condition As String
    condition = "*FolderName*" ' 以“FolderName”为关键字
   
    ' 循环查找符合条件的文件夹
    Dim fso As Object
    Dim sourceFolder As Object
    Dim subFolder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sourceFolder = fso.GetFolder(sourcePath)
    For Each subFolder In sourceFolder.SubFolders
        If InStr(subFolder.Name, condition) > 0 Then
            ' 符合条件，则剪切到目标路径中
            fso.MoveFolder subFolder.Path, targetPath & subFolder.Name
        End If
    Next subFolder
End Sub

qdtzq

FSO了解一下吧

3190496160

Sub 移动文件夹()
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:a" & r)
End With
lj = ThisWorkbook.Path & "\原来文件夹\"
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        wjj = lj & ar(i, 1)
        If fso.folderexists(wjj) Then
            fso.movefolder wjj, ThisWorkbook.Path & "\结果\"
        End If
    End If
Next i
Set fso = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

如何将符合条件的文件夹剪切至另一个文件夹中.rar (230.71 KB, 下载次数: 30)

2023-6-1 14:39 上传

点击文件名下载附件

1042271867

感谢老师，完全达到我的想法

limonet

关键字：move

limonet

Sub limonet()
    CreateObject("wscript.shell").Run "powershell (cd " & ThisWorkbook.Path _
    & ");(move 原来文件夹\" & Join(Application.Transpose(Range("A2:A" & Range("A" _
    & Rows.Count).End(xlUp).Row)), ",原来文件夹\") & " 结果)", 0
End Sub

cai2532

这个将符合条件的文件夹剪切至另一个文件夹中是好贴，收藏了。