VBA关于文件夹的复制，遍历，查询等综合案列求助

itmwdtn

xiangbaoan 发表于 2018-8-7 10:16
仅测试参考，也是帮你顶一下。

我提出一个更细化的问题，如果说相应客户的[技术文件]中的型号，如果不含有标签。那么这个型号就，不要复制过去了，要不然等会删除，文件名不含标签，的文件的时候，就形成了空的文件夹

itmwdtn

itmwdtn 发表于 2018-8-8 10:27
太强大了，我再仔细研究一下

或者说，可以在，最终文件个数为0的时候，将该文件夹删掉

xiangbaoan

itmwdtn 发表于 2018-8-8 11:02
我提出一个更细化的问题，如果说相应客户的[技术文件]中的型号，如果不含有标签。那么这个型号就，不要复 ...

For Each fld In fso.getfolder(p).subfolders
    If fld.Name <> "技术文件" Then
        For Each sfd In fld.subfolders
            For Each f In sfd.Files
                If InStr(f.Name, "标签") = 0 Then Kill f
            Next
            If sfd.Files.Count = 0 Then RmDir sfd.Path '此句删除子文件夹中空文件夹
        Next
    End If
Next
'请加上红色的一句，它判断文件夹中无文件时，就删除此子文件夹，请自行测试反馈。
………………………………………………………………

下为补充添加，可删除当前文件夹下的空文件夹，你视情况运行，你也可以在上段后面加上，自己看着办

call  删除当前文件夹中的空文件夹'加与不加自己决定

Sub 删除当前文件夹中的空文件夹() '如 JS180101，JS180201 这样为空的文件夹，单独运行
On Error Resume Next
Dim fld
fld = Dir(ThisWorkbook.Path & "\", 16)
Do While fld <> ""
If fld <> "技术文件" Then
    RmDir ThisWorkbook.Path & "\" & fld
End If
fld = Dir
Loop
End Sub

itmwdtn

xiangbaoan 发表于 2018-8-8 11:20
For Each fld In fso.getfolder(p).subfolders
    If fld.Name  "技术文件" Then
        For Each sf ...

我想重命名，好像还实现不了。。。
Sub 删除当前文件夹中的空文件夹() '如 JS180101，JS180201 这样为空的文件夹，单独运行
On Error Resume Next
Dim fld
fld = Dir(ThisWorkbook.Path & "\", 16)
Do While fld <> ""
If fld <> "技术文件" Then
   If fld.Count = 0 Then
    Name ThisWorkbook.Path & "\" & fld As ThisWorkbook.Path & "\" & fld & "不含标签"
   End If
End If
fld = Dir
Loop
End Sub


另外，如果我的[技术文件]内的资料不全，也就是总表中，如果出现的型号，在[技术文件]中找不到，那么我希望做个提示：msgbox “在技术文件中找不到该型号文件”  并且 在总表中，将该型号，以红色字体显示。或者可以在复制过去的文件夹中，新建该型号的文件夹，文件夹名称为该型号+不存在。如果能做到后者的最好

xiangbaoan

itmwdtn 发表于 2018-8-8 13:21
我想重命名，好像还实现不了。。。
Sub 删除当前文件夹中的空文件夹() '如 JS180101，JS180201 这样为空 ...

'问题真多，自行测试！操作之前请先删除原先自动创建的工作表
Sub test()
Dim ar, p$, sp$, np$, fld, sfd, f, r%, fso As Object, msg$, n%
Set fso = CreateObject("scripting.filesystemobject")
p = ThisWorkbook.Path & "\"
With Sheet1
    .[e1].Resize(888) = ""
    ar = .[a1].CurrentRegion.Resize(, 5)
End With
On Error Resume Next
For r = 2 To UBound(ar)
    np = p & ar(r, 2)
    If Dir(np, vbDirectory) = "" Then fso.createfolder np
    np = np & "\"
    sp = p & "技术文件\" & ar(r, 1) & "\"
    If fso.FolderExists(sp & ar(r, 3)) Then
        fso.movefolder sp & ar(r, 3), np & ar(r, 3)
        ar(r, 5) = "操作成功！"
    Else
        n = n + 1
        ar(r, 5) = ar(r, 3) & "不存在！"
        msg = msg & sp & ar(r, 5) & vbCr
    End If
Next
Err.Clear
For Each fld In fso.getfolder(p).subfolders
    If fld.Name <> "技术文件" Then
        For Each sfd In fld.subfolders
            For Each f In sfd.Files
                If InStr(f.Name, "标签") = 0 Then Kill f
            Next
            If sfd.Files.Count = 0 Then RmDir sfd.Path
        Next
    End If
Next
Set fso = Nothing
Sheet1.[a1].CurrentRegion.Resize(, 5) = ar
Call 删除空文件夹 '根据实际情况自行决定要不要
If n Then MsgBox msg
End Sub
Sub 删除空文件夹()
On Error Resume Next
Dim fld
fld = Dir(ThisWorkbook.Path & "\", 16)
Do While fld <> ""
If fld <> "技术文件" Then
    RmDir ThisWorkbook.Path & "\" & fld
End If
fld = Dir
Loop
End Sub
……………………………………………………
此为编辑补充：我的老大，你怎么又变了要求???……………………………………
再补充，能实现，不想搞了。

itmwdtn

xiangbaoan 发表于 2018-8-8 14:21
'问题真多，自行测试！操作之前请先删除原先自动创建的工作表
Sub test()
Dim ar, p$, sp$, np$, fld,  ...

谢谢，你是好人，技术好强大啊，哈哈~

xiangbaoan

itmwdtn 发表于 2018-8-8 14:36
谢谢，你是好人，技术好强大啊，哈哈~

'你送花还积极！赞一个
'自行测试！操作之前请先删除原先自动创建的工作表（补充：是文件夹，此为更正）
Sub test()
Dim ar, p$, sp$, np$, fld, sfd, f, r%, fso As Object, msg$, n%
Set fso = CreateObject("scripting.filesystemobject")
p = ThisWorkbook.Path & "\"
With Sheet1
    .[e1].Resize(888) = ""
    ar = .[a1].CurrentRegion.Resize(, 5)
End With
On Error Resume Next
For r = 2 To UBound(ar)
    np = p & ar(r, 2)
    If Dir(np, vbDirectory) = "" Then fso.createfolder np
    np = np & "\"
    sp = p & "技术文件\" & ar(r, 1) & "\"
    If fso.FolderExists(sp & ar(r, 3)) Then
        fso.movefolder sp & ar(r, 3), np & ar(r, 3)
        ar(r, 5) = "操作成功！"
    Else
        n = n + 1
        ar(r, 5) = ar(r, 3) & "不存在！"
        msg = msg & sp & ar(r, 5) & vbCr
        fso.createfolder np & ar(r, 3) & "不存在"
    End If
Next
Err.Clear
For Each fld In fso.getfolder(p).subfolders
    If fld.Name <> "技术文件" Then
        For Each sfd In fld.subfolders
            For Each f In sfd.Files
                If InStr(f.Name, "标签") = 0 Then Kill f
            Next
            If sfd.Files.Count = 0 And InStr(sfd.Name, "不存在") = 0 Then RmDir sfd.Path
        Next
    End If
Next
Set fso = Nothing
Sheet1.[a1].CurrentRegion.Resize(, 5) = ar
'Call 删除空文件夹 '根据实际情况自行决定要不要
If n Then MsgBox msg
End Sub
Sub 删除空文件夹()
On Error Resume Next
Dim fld
fld = Dir(ThisWorkbook.Path & "\", 16)
Do While fld <> ""
If fld <> "技术文件" Then
    RmDir ThisWorkbook.Path & "\" & fld
End If
fld = Dir
Loop
End Sub

itmwdtn

xiangbaoan 发表于 2018-8-8 14:46
'你送花还积极！赞一个
'自行测试！操作之前请先删除原先自动创建的工作表（补充：是文件夹，此为更正） ...

兄弟还有最后2个问题：①我想If InStr(f.Name, "标签") = 0 Then Kill f，在删除不含标签的文件的同时，删除文件后缀为.pdf的文件。
                       ②Sub 删除空文件夹()，把这段代码，的删除文件夹，改为重命名。例如：如果删除的是JS180101文件夹,则我需要的是将JS180101重命名为JS180101不含标签

xiangbaoan

itmwdtn 发表于 2018-8-8 16:22
兄弟还有最后2个问题：①我想If InStr(f.Name, "标签") = 0 Then Kill f，在删除不含标签的文件的同时， ...

'自行测试！操作之前请先删除原先自动创建的文件夹
'老大，I 服了 YOU ，我都快被你搞晕了！
Sub test()
Dim ar, p$, sp$, np$, fld, sfd, f, r%, fso As Object, msg$, n%, k%, m%
Set fso = CreateObject("scripting.filesystemobject")
p = ThisWorkbook.Path & "\"
With Sheet1
    .[e1].Resize(888) = ""
    ar = .[a1].CurrentRegion.Resize(, 5)
End With
On Error Resume Next
For r = 2 To UBound(ar)
    np = p & ar(r, 2)
    If Dir(np, vbDirectory) = "" Then fso.createfolder np
    np = np & "\"
    sp = p & "技术文件\" & ar(r, 1) & "\"
    If fso.FolderExists(sp & ar(r, 3)) Then
        fso.movefolder sp & ar(r, 3), np & ar(r, 3)
        ar(r, 5) = "操作成功！"
    Else
        n = n + 1
        ar(r, 5) = ar(r, 3) & "不存在！"
        msg = msg & sp & ar(r, 5) & vbCr
        fso.createfolder np & ar(r, 3) & "不存在"
    End If
Next
Err.Clear
For Each fld In fso.getfolder(p).subfolders
    k = 0
    If fld.Name <> "技术文件" Then
        For Each sfd In fld.subfolders
            For Each f In sfd.Files
                If InStr(f.Name, "标签") = 0 Or InStr(f.Name, ".fdf") Then Kill f
            Next
            If sfd.Files.Count = 0 And InStr(sfd.Name, "不存在") = 0 Then RmDir sfd.Path
        Next
        k = fld.subfolders.Count
        m = 0
        For Each sfd In fld.subfolders
            If InStr(sfd.Name, "不存在") Then m = m + 1
        Next
        If m = k Then Name fld.Path As fld.Path & "不含标签"
    End If
Next
Set fso = Nothing
Sheet1.[a1].CurrentRegion.Resize(, 5) = ar
If n Then MsgBox msg
End Sub
'真晕了，把pdf打成了fdf

itmwdtn

xiangbaoan 发表于 2018-8-8 16:58
'自行测试！操作之前请先删除原先自动创建的文件夹
'老大，I 服了 YOU ，我都快被你搞晕了！
Sub test( ...

哥，如果我的技术文件里面有重复的型号，就是说存在老版的文件，那么是否我能在搜索到多个型号的时候，按照创建时间最新的这样的1个条件，来搜索到我要的文件