VBA新建文件夹并把数据放入

zhangfuqi00

求各位大佬帮忙写个代码，每个都需要在每个子文件夹里新建1个“PIM"文件夹，并把JPG图片放到PIM文件夹里，TXT文件删除，附件已上传

3190496160

Sub test()
Application.ScreenUpdating = False
Dim arr()
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(ThisWorkbook.Path)
For Each fd In f.subfolders
    n = n + 1
    ReDim Preserve arr(1 To n)
    arr(n) = fd.Name
Next
lj = ThisWorkbook.Path & "\"
For i = 1 To n
    mc = arr(i)
    wjj = lj & mc & "\PIM"
    If Not fs.folderexists(wjj) Then fs.CreateFolder wjj
    f = Dir(lj & mc & "\*.jpg")
    Do While f <> ""
        fs.movefile lj & mc & "\" & f, lj & mc & "\PIM\"
    f = Dir
    Loop
Next i
Set f = Nothing
Set fs = Nothing
End Sub

3190496160

3190496160

新建 Microsoft Excel 工作表.rar (15.41 KB, 下载次数: 3)

2023-5-16 17:31 上传

点击文件名下载附件

limonet

代码在审核。

limonet

Sub limonet()
    Dim Path$
    Path = ThisWorkbook.Path
    Call ALlListFSO(Path)
End Sub

Function ALlListFSO(Path) As String
    Dim Fld As Object, Fd As Object, F As Object
    Set Fld = CreateObject("scripting.filesystemobject").getfolder(Path)
    For Each Fd In Fld.subfolders
        If Not Fd.Path Like "*\PIM" Then MkDir (Fd.Path & "\PIM")
        ALlListFSO (Fd.Path)
    Next Fd
    For Each F In Fld.Files
        If F.Name Like "*.txt" Then
            Kill F.Path
        ElseIf F.Name Like "*.jpg" Then Name F.Path As Fld.Path & "\PIM\" & F.Name
        End If
    Next F
End Function

ykcbf1100

附件供参考。。。

zhangfuqi00

3190496160 发表于 2023-5-16 17:31

感谢大佬的帮助

zhangfuqi00

limonet 发表于 2023-5-16 17:33
Sub limonet()
    Dim Path$
    Path = ThisWorkbook.Path

谢谢大佬帮忙

zhangfuqi00

ykcbf1100 发表于 2023-5-16 17:40
附件供参考。。。

谢谢大佬帮忙