[已解决]请各位老师帮忙给解决一个复制文件问题

lchjun

请各位老师帮忙给解决一个问题，谢谢了

a列为文件名表，a2到a6为文件夹名，请问能不能用VBA实现附件中所要复制文件效果。
附件 复制文件.zip (43.27 KB, 下载次数: 17)

2013-9-20 13:46 上传

点击文件名下载附件
附件

2013-9-18 15:13 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-9-20 14:37

1. Sub CopyFiles()
   
2.     Dim strPath$, DstPath$
   
3.     Dim strFilename$, strTemp$
   
4.     Dim i&, j&
   
5.     Dim arr
   
6.     On Error Resume Next
   
7.    
   
8.     strPath = ThisWorkbook.Path & Application.PathSeparator
   
9.     DstPath = strPath & "结果" & Application.PathSeparator
   
10.     arr = Range("a5").CurrentRegion
    
11.     For i = LBound(arr) + 1 To UBound(arr)
    
12.         strTemp = Replace(arr(i, 1), " ", "") & ".doc"
    
13.         If Len(strTemp) > 4 Then
    
14.             For j = LBound(arr, 2) + 1 To UBound(arr, 2)
    
15.                 If Len(arr(i, j)) Then
    
16.                     MkDir (DstPath & arr(i, j))
    
17.                     FileCopy strPath & strTemp, DstPath & arr(i, j) & Application.PathSeparator & strTemp
    
18.                 End If
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     MsgBox "复制完成"
    
23.    
    
24. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

你这可以实现，起码A列的文件名要作标准了嘛。
直接对应要拷贝的文件名比较好。

hwc2ycy

1. Sub CopyFiles()
   
2.     Dim strPath$, DstPath$
   
3.     Dim strFilename$, strTemp$
   
4.     Dim i&, j&
   
5.     Dim arr
   
6.     On Error Resume Next
   
7.    
   
8.     strPath = ThisWorkbook.Path & Application.PathSeparator
   
9.     DstPath = strPath & "结果" & Application.PathSeparator
   
10.     arr = Range("a5").CurrentRegion
    
11.     For i = LBound(arr) + 1 To UBound(arr)
    
12.         strTemp = Replace(arr(i, 1), " ", "") & ".doc"
    
13.         If Len(strTemp) > 4 Then
    
14.             For j = LBound(arr, 2) + 1 To UBound(arr, 2)
    
15.                 If Len(arr(i, j)) Then
    
16.                     MkDir (DstPath & arr(i, j))
    
17.                     FileCopy strPath & strTemp, DstPath & arr(i, j) & Application.PathSeparator & strTemp
    
18.                 End If
    
19.             Next
    
20.         End If
    
21.     Next
    
22.     MsgBox "复制完成"
    
23.    
    
24. End Sub

复制代码

lchjun

没想到这么快真是高手啊，万分感谢！
不好意思我注意文件名写错了 我是新人，请帮我把代码加到附件里好吗。谢谢
新建文件夹.zip (12.33 KB, 下载次数: 7)

2013-9-20 15:02 上传

点击文件名下载附件

lchjun

已经成功了 ，谢谢{:021:}