Folder & File Reorganization - Error 13 Mismatch

[JohnHenry]

I was trying to help my HR department out real quick with a folder reorg/rename project. My code below works great for all of the pdf files, bur errors out with Microsoft files. Yes, it is a very brute force method, but the idea was a one-time use... Any help would be appreciated.

Option Explicit
Sub FolderCreate_FileMove_FileRename()
    Dim EmployeeName As String
    Dim EmployeeSearchName As String
    Dim OldFolderPath As String
    Dim NewFileName As String
    Dim OldFileName As String
    Dim strFileName As Variant
    Dim N As Long, J As Long
    Dim OldFolderPathCol As Variant
    Dim OldFolderNameColsArray
    Dim objShell As Variant
    Dim objFolder As Variant
    Dim FileType As Variant
    Dim DoubleDoc As Integer
    
    Dim Test1 As Variant
    Dim Test2 As Variant
    Dim Test3 As String
    Dim FullFileName
    
    OldFolderNameColsArray = Array("F", "H", "J", "L", "N", "P", "R", "T", "V", "X", "Z", "AB", "AD", _
                            "AF", "AH", "AJ", "AL", "AN", "AP", "AR", "AT", "AV", "AX", "AZ", _
                            "BB", "BD", "BF", "BH", "BJ", "BL", "BN", "BP", "BR", "BT", "BV", "BX")
    N = Cells(Rows.Count, "B").End(xlUp).Row
    For J = 150 To N
    If Evaluate("MOD(" & J & ",300)") = 0 Then Sheets("Debugger").Activate
Application.ScreenUpdating = False
        Sheets("All").Activate
        If Cells(J, "D") = "Duplicate?" Then GoTo NextRecord
        EmployeeName = Cells(J, "B").Text
        EmployeeSearchName = EmployeeSearchNameFunc(EmployeeName)
        For Each OldFolderPathCol In OldFolderNameColsArray
        
            OldFolderPath = Cells(J, OldFolderPathCol).Value
            'If OldFolderPathCol = "BT" Then Sheets("debugger").Activate
            Set objShell = CreateObject("Shell.Application")
            Set objFolder = objShell.Namespace((OldFolderPath))
    
            DoubleDoc = 0
            For Each strFileName In objFolder.Items
Application.ScreenUpdating = False
                OldFileName = objFolder.GetDetailsOf(strFileName, 0)
                If InStr(1, EmployeeSearchName, OldFileName, vbTextCompare) > 0 Or InStr(1, OldFileName, EmployeeSearchName, vbTextCompare) > 0 Then
                    If Cells(J, "E") = "N" Then
                        MkDir ("H:\PT Folder Reorganization\PT\" & EmployeeName)
                        Cells(J, "E") = "Y"
                    End If
                    
                    Cells(J, Cells(J, OldFolderPathCol).Column + 1).Value = "Moved from " & OldFolderPath & "\" & OldFileName
                    FileType = objFolder.GetDetailsOf(strFileName, 2)
                    DoubleDoc = DoubleDoc + 1
                    
                    'On Error Resume Next 'GoTo NextRecord
                    If DoubleDoc = 1 And FileType <> "File" Then
                        If OldFolderPath = "H:\PT Folder Reorganization\PT_Copy\Warnings- Unsatisfactory Perf\Performance Report Warnings" Then
                            Cells(J, Cells(J, OldFolderPathCol).Column + 1).Value = "Bad Folder Name"
                        ElseIf FileType = "TIF File" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".TIF"
                            'FullFileName = "H:\PT Folder Reorganization\PT_Copy\W4\Aasen , Andrea - Exempt.pdf"
                                Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & Cells(J, OldFolderPathCol).Address & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)") & ".TIF"
                        ElseIf FileType = "PDF File" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".pdf"
                            'FullFileName = "H:\PT Folder Reorganization\PT_Copy\W4\Aasen , Andrea - Exempt.pdf"
                                Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & Cells(J, OldFolderPathCol).Address & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)") & ".pdf"
                        'ElseIf Evaluate("LEFT(" & FileType & ",14)") = "Microsoft Word" Then
                        ElseIf FileType = "Microsoft Word 97 - 2003 Document" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".doc"
                            Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & OldFolderPath & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36).doc")
                        'ElseIf Evaluate("LEFT(" & FileType & ",15)") = "Microsoft Excel" Then
                        ElseIf FileType = "Microsoft Excel Worksheet" Or FileType = "Microsoft Excel 97-2003 Worksheet" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".xls"
                            Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & OldFolderPath & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36).xls")
                        Else: Sheets("Debugger").Activate
                        End If
                    ElseIf DoubleDoc > 1 And FileType <> "File" Then
                        If OldFolderPath = "H:\PT Folder Reorganization\PT_Copy\Warnings- Unsatisfactory Perf\Performance Report Warnings" Then
                            Cells(J, Cells(J, OldFolderPathCol).Column + 1).Value = "Bad Folder Name"
                        ElseIf FileType = "PDF File" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".pdf"
                                Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & Cells(J, OldFolderPathCol).Address & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)") & " " & DoubleDoc & ".pdf"
                        ElseIf FileType = "TIF File" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".TIF"
                                Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & Cells(J, OldFolderPathCol).Address & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)") & " " & DoubleDoc & ".TIF"
                        'ElseIf Evaluate("LEFT(" & FileType & ",14)") = "Microsoft Word" Then
                        ElseIf FileType = "Microsoft Word 97 - 2003 Document" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".doc"
                            Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & OldFolderPath & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)" & "_" & Evaluate("TEXT(" & DoubleDoc & ",0)") & ".doc")
                        ElseIf FileType = "Microsoft Excel Worksheet" Or FileType = "Microsoft Excel 97-2003 Worksheet" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".xls"
                            Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & OldFolderPath & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)" & "_" & DoubleDoc & ".xls")
                        Else: Sheets("Debugger").Activate
                        End If
                    End If
                
                    Cells(J, Cells(J, OldFolderPathCol).Column + 1).Value = Cells(J, Cells(J, OldFolderPathCol).Column + 1).Value + "   TO   H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & Cells(J, OldFolderPathCol).Address & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)")
                    'GoTo NextRecord
                End If
            Next
            If Left(Cells(J, Cells(J, OldFolderPathCol).Column + 1).Text, 5) <> "Moved" Then
                Cells(J, Cells(J, OldFolderPathCol).Column + 1).Value = "File Not Found"
            End If
NextRecord:
        Next
        Set objFolder = Nothing
        Set objShell = Nothing
    Next J
End Sub
Function EmployeeSearchNameFunc(s As String) As String
    'Variables
        Dim RetVal As String 'This is the return string.
        Dim CharacterCounter As Integer 'Counter for character position in input string
        Dim SpaceCounter As Integer
    RetVal = "" 'Reset return string to empty
    'For every character in input string, copy character to return string
        SpaceCounter = 0 'Reset
        For CharacterCounter = 1 To Len(s)
            If Mid(s, CharacterCounter, 1) = " " Then
                SpaceCounter = SpaceCounter + 1
                If SpaceCounter = 2 Then Exit For
                RetVal = RetVal + Mid(s, CharacterCounter, 1)
            Else: RetVal = RetVal + Mid(s, CharacterCounter, 1) 'Add character to RetVal String
            End If
        Next
EmployeeSearchNameFunc = RetVal 'Then return the return string.
End Function

Thanks! John

 

[AlphaFrog]

This line is different for the PDF files.
Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & Cells(J, OldFolderPathCol).Address & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36)") & ".pdf"


Compared to the Microsoft files...
Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Evaluate("RIGHT(" & OldFolderPath & ",LEN(" & Cells(J, OldFolderPathCol).Address & ")-36).doc")


I would guess the error is the path is not extracted correctly for the Microsoft files. It's hard to say without knowing the nature of the data. It looks like you may have a parenthesis in the wrong place?

Also note; both Right and Len are VBA commands. You could extract the path from the cell values without the need to evaluate a formula. I think this is the equivalent without EVALUATE
Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Right(OldFolderPath, Len(Cells(J, OldFolderPathCol) - 36)) & ".doc"

 

[JohnHenry]

AlphaFrog

Thanks for the tip, all this time with those obnoxious Evaluate statements…

Good catch with the differences from pdf, I have definitely been too immersed. The “FileType” Is pulling correctly and the module continues into the then statement, it just errors out with the actually renaming portion. I will clean up without the evaluate statements and see if it becomes obvious….

John

 

[JohnHenry]

It had something to do with my Len statement erroring out. I never would have caught it if I hadn’t gotten rid of the Evaluate statements. I replaced the line with the following:

                        ElseIf FileType = "Microsoft Word 97 - 2003 Document" Then
                            FullFileName = OldFolderPath & "\" & OldFileName & ".doc"
                            Name FullFileName As "H:\PT Folder Reorganization\PT\" & EmployeeName & "\" & Right(Cells(J, OldFolderPathCol).Text, Len(Cells(J, OldFolderPathCol).Text) - 36) & ".doc"

Thank you Alphafrog!