Word转移的问题

常扬帆

请问：如何文件夹里的Word转移到另一个文件夹的对应的子文件夹里？谢谢您！

比如，把员工档案里唐僧的Word文档转移到员工档案汇总的唐僧文件夹里。

过客fppt

原来的状态


运行代码后

过客fppt

1. Sub 文档转移文件夹3()
   
2.     源文件夹 = "H:\用户\桌面\新建文件夹\员工档案"
   
3.     目标文件夹 = "H:\用户\桌面\新建文件夹\员工档案汇总\唐僧"
   
4.    
   
5.     Set FSO = CreateObject("Scripting.FileSystemObject")
   
6.     Set 文件夹 = FSO.GetFolder(源文件夹)
   
7.    
   
8.     '建立数组储存找到的文件名
   
9.     Dim 文件名() As String
   
10.     Dim wName As String, newName As String
    
11.    
    
12.     '要转移的文件
    
13.     wName = InputBox("请输入要转移的文件名：")
    
14.    
    
15.     Dim j As Integer
    
16.     For Each f In 文件夹.Files
    
17.         If Right(f.Name, 3) = "doc" Or Right(f.Name, 4) = "docx" Then
    
18.             ReDim Preserve 文件名(j)
    
19.             文件名(j) = f.Path
    
20.             If InStr(文件名(j), wName) > 0 Then
    
21.                 newName = 目标文件夹 & "" & f.Name
    
22.                 FSO.CopyFile 文件名(j), newName, True ' 将文件复制到目标位置
    
23.                 FSO.DeleteFile 文件名(j) ' 删除原文件
    
24.                 Debug.Print "完成转移文件" & j & "：" & 文件名(j)
    
25.                 Exit For
    
26.             End If
    
27.             j = j + 1
    
28.         End If
    
29.     Next
    
30.    
    
31. End Sub

复制代码

过客fppt

这里注意改一下

gwjkkkkk

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp" (ByVal PathName As String) As Long
Option Explicit
Sub test()
    Dim ar(), r&, strFileName$, strPath1$, strPath2$
   
    Application.ScreenUpdating = False
    strPath2 = ThisDocument.Path & "\员工档案汇总\"
    strPath1 = ThisDocument.Path & "\员工档案\"
    strFileName = Dir(strPath1 & "*.doc*")
    Do Until strFileName = ""
        If strFileName Like "*.doc*" Then
            r = r + 1
            ReDim Preserve ar(1 To 3, 1 To r)
            ar(1, r) = strPath1 & strFileName
            ar(2, r) = strPath2 & Left(strFileName, InStrRev(strFileName, ".") - 1) & "\"
            MakeSureDirectoryPathExists ar(2, r)
            Name ar(1, r) As ar(2, r) & strFileName
        End If
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

利用API，请参考。。。

常扬帆

gwjkkkkk 发表于 2024-2-2 20:47
利用API，请参考。。。

衷心感谢您！您知道我的水平只达到了，修改文件名称和运行宏的高度。一运行就成功了！