CODEWITHSUNDEEP
excelvba
Matt Taylor
Matt Taylor

Reputation: 671

Move files to specific folders based on 7th character of filename

I am trying to move recently renamed files from a Temp folder to a destination folder based on the filenames 7th character.

For example every filename's 7th Character is the size of the drawing. So what I am trying to do is if the filename's 7th chr is = A then move the file to "...\A-SIZE_8.5X11" folder.

*Note that the MainDir is created from the autocad script when it prints a PDF.

Currently I am getting an error at If Mid(Dir(s, vbDirectory), x).Value = "A" Then Says Type Mismatch. Any feedback is much appreciated.

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

Modified If statements so loop ends before Dir is called again. Found part of this code online and tried modifying it to work but im not sure how to fix it.

Upvotes: 1

Views: 150

Answers (1)

omegastripes
omegastripes

Reputation: 12612

Take a look at the below example:

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

Upvotes: 1

Related Questions