On Error Resume Next
Dim strFolder1,strFolder2
strFolder1="D:\A"  '//要查找的目录
strFolder2="E:\B\"  '//目标目录,注意后面的反斜杠要加上
Call CopyFiles(strFolder1)
MsgBox "完成！"
WScript.Quit
Sub CopyFiles(strPath)
  Dim Folder,subFolders,Files,File,fso
  Set fso = CreateObject("Scripting.FileSystemObject") 
  Set Folder = fso.Getfolder(strPath)
  Set subFolders = Folder.subFolders
  Set Files = Folder.Files
  For Each File In Files
      fso.CopyFile File.Path,strFolder2,False '设置为false，表示如果文件存在则不覆盖
      If Err.Number<>0 Then Err.Clear
  Next
  For Each subfolder In subFolders
      CopyFiles(subFolder.Path) '递归查找子目录
  Next
End Sub
复制代码

Option Explicit

Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")

XCopy objFSO, "D:\A", "E:\B", False

MsgBox "复制完成。", vbInformation, "完成"

'********************************************************************
'* Sub :     XCopy
'*
'* Purpose:  复制文件和目录树。
'*
'* Input:    fso            FileSystemObject 对象实例
'*           source         指定要复制的文件。
'*           destination    指定新文件的位置和/或名称。
'*           overwrite      是否覆盖已存在文件。 Ture 覆盖， False 跳过
'*
'* Output:   -
'*
'********************************************************************
Sub XCopy(fso, source, destination, overwrite)
    Dim s, d, f, l
    Set s = fso.GetFolder(source)
    If Not fso.FolderExists(destination) Then
        fso.CreateFolder destination
    End If
    Set d = fso.GetFolder(destination)
    For Each f In s.Files
        l = d.Path & "\" & f.Name
        If Not fso.FileExists(l) Or overwrite Then
            If fso.FileExists(l) Then
                fso.DeleteFile l, True
            End If
            f.Copy l, True
        End If
    Next
    For Each f In s.SubFolders
        XCopy fso, f.Path, d.Path & "\" & f.Name, overwrite
    Next
End Sub
复制代码