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

Mangnin

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

2016-6-21 20:04 上传

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

最佳答案

月排行榜 / 总排行榜

老司机带带我

2016-6-21 21:50

代码如下：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
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 Target.Address <> "$D$1" And Target = "" 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, "A", "")
    
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 & "" & dc(k)
    
26.         Next
    
27.     End If
    
28. End Sub

复制代码

跳转到最佳答案楼层

老司机带带我

代码如下：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
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 Target.Address <> "$D$1" And Target = "" 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, "A", "")
    
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 & "" & dc(k)
    
26.         Next
    
27.     End If
    
28. End Sub

复制代码

JX_shangrila

Sub 复制文件夹()
    Dim fso As Object
    On Error Resume Next
    Application.DisplayAlerts = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    a = [d1]
    mypath = ThisWorkbook.Path & "\"
    myname = Dir(mypath, vbDirectory)
    Do While myname <> ""
       If Left(myname, 1) = "A" Then fso.CopyFolder mypath & myname & "\" & a, mypath & "\新建文件夹\" & Split(myname, "A")(1)
       myname = Dir
    Loop
    Application.DisplayAlerts = True
    Set fso = Nothing
End Sub

JX_shangrila

按楼主要求把所有A字头文件夹下的名称为 d1单元格的文件夹（包括该文件夹下的子文件夹和全部文档） 全部复制到新建文件夹中，并按要求更改该文件夹名称。

JX_shangrila

操作方法如下

Mangnin

JX_shangrila 发表于 2016-6-21 23:00
操作方法如下

看不明白。