时间戳

首页 > 解决方案 > 根据文件名的第 7 个字符将文件移动到特定文件夹

excel - 根据文件名的第 7 个字符将文件移动到特定文件夹

问题描述

我正在尝试根据文件名第 7 个字符将最近重命名的文件从 Temp 文件夹移动到目标文件夹。

例如，每个文件名的第 7 个字符就是图形的大小。所以我想要做的是，如果文件名的第 7 个字符是 = A，那么将文件移动到“...\A-SIZE_8.5X11”文件夹。

*请注意，MainDir 是在打印 PDF 时从 AutoCAD 脚本创建的。

目前我在If Mid(Dir(s, vbDirectory), x).Value = "A" Then说类型不匹配时遇到错误。非常感谢任何反馈。

Sub MoveFiles()
Dim s As String, x As String
Dim LoginName As String, MainDir As String, 
SourceDir As String
Dim destDirA As String, destDirB As String, 
destDirC As String, destDirD As String

LoginName = UCase(GetUserID)
MainDir = "C:\Users\" & LoginName & "\Desktop\PDF\"
SourceDir = MainDir & "_Temp\"
destDirA = MainDir & "A-SIZE_8.5X11"
destDirB = MainDir & "B-SIZE_11X17"
destDirC = MainDir & "C-SIZE_17X22"
destDirD = MainDir & "D-SIZE_24X36"

s = (SourceDir & "\*.pdf?")
x = Mid(s, 7, 1) 'Find letter after S-000-

If Mid(Dir(s, vbDirectory), x).Value = "A" Then
    If Len(Dir(destDirA, vbDirectory)) = 0 Then MkDir destDirA
        Do
        Name SourceDir & s As destDirA & s & "\" & s
    Loop Until s = ""
End If

If Mid(Dir(s, vbDirectory), x).Value = "B" Then
    If Len(Dir(destDirB, vbDirectory)) = 0 Then MkDir destDirB
        Do
        Name SourceDir & s As destDirB & s & "\" & s
    Loop Until s = ""
End If

If Mid(Dir(s, vbDirectory), x).Value = "C" Then
    If Len(Dir(destDirC, vbDirectory)) = 0 Then MkDir destDirC
        Do
        Name SourceDir & s As destDirC & s & "\" & s
    Loop Until s = ""
End If

If Mid(Dir(s, vbDirectory), x).Value = "D" Then
    If Len(Dir(destDirD, vbDirectory)) = 0 Then MkDir destDirD
        Do
        Name SourceDir & s As destDirD & s & "\" & s
    Loop Until s = ""
End If
End Sub

修改后的 If 语句使循环在 Dir 再次被调用之前结束。在网上找到了这段代码的一部分并尝试修改它以使其工作，但我不确定如何修复它。

标签： excelvba

解决方案

看看下面的例子：

Option Explicit

Sub TestShellApp()

    Dim sSourceFolder As String
    Dim sTargetFolder As String
    Dim sSourcePattern
    Dim sTargetPath As String
    Dim oShellApp
    Dim oSourceFolder
    Dim oSourceFolderItems
    Dim oTargetFolder
    Dim sKey

    sSourceFolder = "C:\Test\Source\"
    sTargetFolder = "C:\Test\Target\"

    Set oShellApp = CreateObject("Shell.Application")
    Set oSourceFolder = oShellApp.Namespace((sSourceFolder))
    Set oSourceFolderItems = oSourceFolder.Items()
    With CreateObject("Scripting.Dictionary")
        .Item("A") = "A-SIZE_8.5X11"
        .Item("B") = "B-SIZE_11X17"
        .Item("C") = "C-SIZE_17X22"
        .Item("D") = "D-SIZE_24X36"
        For Each sKey In .Keys
            sTargetPath = sTargetFolder & .Item(sKey)
            SmartCreateFolder sTargetPath
            Set oTargetFolder = oShellApp.Namespace((sTargetPath))
            For Each sSourcePattern In Array( _
                    "??????" & sKey & "*", _
                    "????????" & sKey & "*" _
                )
                oSourceFolderItems.Filter 32 + 64 + 128, sSourcePattern
                oTargetFolder.MoveHere oSourceFolderItems, 16 + 1024
            Next
        Next
    End With
    MsgBox "Files moved"

End Sub

Sub SmartCreateFolder(sFolder)

    Static oFSO As Object

    If oFSO Is Nothing Then Set oFSO = CreateObject("Scripting.FileSystemObject")
    With oFSO
        If Not .FolderExists(sFolder) Then
            SmartCreateFolder .GetParentFolderName(sFolder)
            .CreateFolder sFolder
        End If
    End With

End Sub

推荐阅读