批量复制文件，并进行重命名

Question

a、b、c......等文件夹在同一个文件夹之下，在a文件夹下有一个1.txt的文件，在b文件夹下也有一个1.txt的文件，......，现在我想把这些文件夹下的1.txt的文件都复制到另外一个名字为123的文件夹下，并对他们进行重命名，重命名之后的文件名分别对应于原来的文件夹名，即为a.txt，b.txt等等。
求哪位大侠给详细解答一下，不胜感激！

Answer 1

Sub 获取文价夹名称并重命名()
Dim myfiles, fs, fd, path
Dim i As Long
Set myfiles = CreateObject("Scripting.FileSystemObject")
path = InputBox("输入文件夹路径", , "C:\Documents and Settings\Administrator\桌面\12\")

Set fs = myfiles.getfolder(path)
On Error Resume Next
Application.ScreenUpdating = True
Application.DisplayAlerts = False
i = 1

For Each fd In fs.subfolders
'subfolders描述返回由指定文件夹中所有子文件夹
'（包括隐藏文件夹和系统文件夹）组成的Folders集合
Cells(i, 1) = fd.Name
i = i + 1
Next
Stop
For i = 1 To Range(Cells(1, 1), Cells(1, 1).End(4)).Count
FileCopy path & Cells(i, 1) & "\1.txt", _
"C:\Documents and Settings\Administrator\桌面\123\1.txt"
Name "C:\Documents and Settings\Administrator\桌面\123\1.txt" As _
"C:\Documents and Settings\Administrator\桌面\123\" _
& Cells(i, 1) & ".txt"
Next
Set fs = Nothing
Set fd = Nothing
End Sub