Folder & File Reorganization - Error 13 Mismatch

JohnHenry

New Member
Joined
Mar 12, 2013
Messages
27
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.
Code:
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

MrExcel MVP
Joined
Sep 2, 2009
Messages
16,166
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"
 
Last edited:

JohnHenry

New Member
Joined
Mar 12, 2013
Messages
27
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

New Member
Joined
Mar 12, 2013
Messages
27
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:
Code:
                        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!
 

Forum statistics

Threads
1,082,276
Messages
5,364,195
Members
400,786
Latest member
ismi88

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top