求助，复制文件

虔诚的小草

ykcbf1100 发表于 2024-5-17 15:39
下面不是还有个自定义函数吗？

哦，明白了，晚点有空再测试下。原来是要和之前发的合并下。。。。忘记前面还有 Function自定义了。

limonet

关键字：recurse+Include

limonet

Sub limonet()
    Dim WSHShell As Object, Arr As Variant, ArrT As Variant, i%, F$, Path$
    For Each a In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).subfolders
        F = a.Name
    Next a
    Path = ThisWorkbook.Path & "\" & F
    Set WSHShell = CreateObject("Wscript.Shell")
    WSHShell.CurrentDirectory = Path
    Arr = Split(WSHShell.Exec("Powershell get-childitem -recurse -file  -Include *清单.xls? | select name").StdOut.ReadAll, Chr(13) & Chr(10))
    WSHShell.Run "Powershell get-childitem -recurse -file  -Include *清单.xls? -name | copy-item -Destination (md out)", 0, True
    For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
        ArrT = Filter(Arr, Cells(i, "B"))
        If UBound(ArrT) = -1 Then
            Cells(i, "D") = "无文件"
        Else
            Cells(i, "D") = "已复制"
            Cells(i, "H") = ArrT(0)
            Name Path & "\out\" & Cells(i, "H") As Path & "\out\!" & Cells(i, "A") & "-" & Cells(i, "B") & "!" & Cells(i, "C") & "!" & F & "!.xlsx"
        End If
    Next i
End Sub

虔诚的小草

limonet 发表于 2024-5-17 17:38
关键字：recurse+Include

不得不说强！调用的那个是什么？？多运行几次会出现文件找不到。不过不得不说真的强！

虔诚的小草

limonet 发表于 2024-5-17 17:38
关键字：recurse+Include

powershell，杀毒软件会阻止。

limonet

虔诚的小草 发表于 2024-5-19 09:53
powershell，杀毒软件会阻止。

获取文件清单是powershell，只有获取、复制代码，其他工作是普通的VBA函数或代码；没有装第三方其他杀毒软件，没法尝试，但是代码清晰，没有删除与改名等高危操作。