[已解决]复制文件夹并重命名的问题

HaiMi

附件 复制文件夹并重命名.rar (277.3 KB, 下载次数: 24)

2016-6-13 08:50 上传

点击文件名下载附件
谢谢！

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-13 10:42

1. Sub xx()
   
2.     Dim dc, MyName$, MyPath$, objShell, fso As Object
   
3.     Set dc = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set objShell = CreateObject("Shell.Application")
   
6.     MyPath = ThisWorkbook.Path & ""
   
7.     MyName = Dir(MyPath, vbDirectory)
   
8.     If Sheet1.[D1] = "" Then Exit Sub
   
9.     Do While MyName <> ""
   
10.         If MyName <> "." And MyName <> ".." Then
    
11.             If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
    
12.                 dc.Add (MyPath & MyName & ""), Replace(MyName, "B", "")
    
13.             End If
    
14.         End If
    
15.         MyName = Dir
    
16.     Loop
    
17.     Set objFolder = objShell.BrowseForFolder(0, "选择文件目录", 0, 0)
    
18.     If Not objFolder Is Nothing Then
    
19.         MyPath = objFolder.self.Path
    
20.     Else
    
21.         MyPath = ""
    
22.     End If
    
23.     If MyPath <> "" Then
    
24.         For Each k In dc.keys
    
25.             fso.CopyFolder k & Sheet1.[D1], MyPath & "\A" & dc(k)
    
26.         Next
    
27.     End If
    
28. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

1. Sub xx()
   
2.     Dim dc, MyName$, MyPath$, objShell, fso As Object
   
3.     Set dc = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set objShell = CreateObject("Shell.Application")
   
6.     MyPath = ThisWorkbook.Path & ""
   
7.     MyName = Dir(MyPath, vbDirectory)
   
8.     If Sheet1.[D1] = "" Then Exit Sub
   
9.     Do While MyName <> ""
   
10.         If MyName <> "." And MyName <> ".." Then
    
11.             If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then
    
12.                 dc.Add (MyPath & MyName & ""), Replace(MyName, "B", "")
    
13.             End If
    
14.         End If
    
15.         MyName = Dir
    
16.     Loop
    
17.     Set objFolder = objShell.BrowseForFolder(0, "选择文件目录", 0, 0)
    
18.     If Not objFolder Is Nothing Then
    
19.         MyPath = objFolder.self.Path
    
20.     Else
    
21.         MyPath = ""
    
22.     End If
    
23.     If MyPath <> "" Then
    
24.         For Each k In dc.keys
    
25.             fso.CopyFolder k & Sheet1.[D1], MyPath & "\A" & dc(k)
    
26.         Next
    
27.     End If
    
28. End Sub

复制代码

HaiMi

老司机带带我 发表于 2016-6-13 10:42

老师你好，刚试了一下完整的数据，发现不能完全运行。情形如下：

B字头文件夹共49个，B1---B49

每个B字头文件夹下，共有11个A字头文件夹。命名为A1 A2......A11,所有B字头文件夹下，都是这A1---A11……所有A字头文件夹下，都有49个工作薄。

在D1输入 A11后，只复制出19个A字头文件夹。如下图

老司机带带我

HaiMi 发表于 2016-6-13 17:24
老师你好，刚试了一下完整的数据，发现不能完全运行。情形如下：

B字头文件夹共49个，B1---B49

晚上测试下回复你吧！

我刚刚测试了一下没问题啊，是不是你的文件名称有问题？会不会有的B中没有A11？

Mangnin

老司机带带我 发表于 2016-6-13 17:30
晚上测试下回复你吧！

我刚刚测试了一下没问题啊，是不是你的文件名称有问题？会不会有的B中没有A11？

老师你好。麻烦看看 复制文件夹并重命名  与原来那个差不多。我原用户名没用了。