VBA Filing to a folder - I have been stuck on this for a MONTH!

alf810

New Member
Joined
Dec 30, 2015
Messages
17
Hey everyone,

At my work I'm trying to use Excel VBA to take scanned PDF documents of patient information from the path they're scanned into and have a macro that will automatically go through the PDF files, look at the name of the files and be able to go to another path (patient accounts directly) and put said file into the correct patient folder.

Step-by-Step
Macro looks at the first PDF file in scanned folder
The PDF files will be named with two letters and up to six numbers. The letters represent the first two letters of the patient's last name, the number represents the account.
Macro looks at the two letters, goes to the patient accounts directly and determines the correct letter (folders are split as: Aa-Al, Am-Az, Ba-Bl, Bm-Bz, etc...)
Macro goes into correct alphabetic folder and looks for the exact account number (if patient's number is 112, and another patient is 1125, it might cause an issue otherwise)
If Macro finds the folder then it simply moves the file to the folder. If Macro doesn't find the folder then I want it to just place the folder in a "TO FILE" folder on my computer.
Macro then looks at the next PDF file, process is repeated.

I want to thank user LockeGarmin for helping me on this Macro. He got it to work perfectly at my home computer (Excel 2016), but my work computer is give me issues (either Excel 2010 or 2013, I believe it is 2013). I would think it would be a network issue (the folders are on different drives), however when in debug mode it looks like the paths are all fully recognized, as well as the file name that needs to be moved, so I'm wondering if it's a version issue?

Things don't get screwed up (again at work, not home) until around where the code states Set CustomerDirectly = FindCustomer[[SurnamePrefix, AccountNumber, CustomerDocumentsDirectly

It seems after this code, in debug mode) a lot of variables just start equally "Nothing" instead of a proper path or file. Even in the Function FindCustomerFolder(SurnamePrefix As String, AccountNumber As String, CustomerDocumentsDirect As Object) As Object pretty much everything equals "nothing", including Folder itself at that point.

When I do try to run the script I get an error around the For Each Folder in SurnameGroupFolder.SubFolders... etc.. the error states that I am missing a With block?

Here's the code, please help if you can. You can edit the code below or create your own if you feel you could make that'll work on an Excel 2013 working with network drives. Also, if the folders going alphabetically seems too difficult (like South, Adam #1115, file called SO1115.PDF going into Sm-Sz, then I can name the first half of files with only A and the second with only Z, if it's easier, so the above filed would be called SZ1115.PDF). Anyway, thanks for any help!

Code:
Option Explicit
 
Sub MoveFiles()
 
Dim Folder As Object
Dim File As Object
 
Const FolderPath As String = "C:\Users\MIS\Documents\MACRO TEST\ScannerDocs"
 
 
  Set Folder = CreateObject("Scripting.FileSystemObject").GetFolder(FolderPath)
  
  For Each File In Folder.Files
    Call MoveCustomerDocument(File.Path)
  Next File
 
End Sub
 
Sub MoveCustomerDocument(DocumentPath As String)
 
Const CustomerDocumentsDirectoryPath As String = "C:\Users\MIS\Documents\MACRO TEST\CustomerDocs"
Const NewCustomerDocumentsDirectoryPath As String = "C:\Users\MIS\Documents\MACRO TEST\NewCustomers"
 
Dim FSO As Object 'Scripting.FileSystemObject
Dim CustomerDocumentsDirectory As Object 'Scripting.Folder
Dim CustomerDirectory As Object 'Scripting.Folder
 
Dim DestinationDirectoryPath As String
 
Dim DocumentName As String
Dim SurnamePrefix As String
Dim AccountNumber As String
 
  Set FSO = CreateObject("Scripting.FileSystemObject")
 
  'There could be room for error checking in this section in case an improper file name is passed into the function i.e. "arc123" instead of "ar123"
  SurnamePrefix = Left$(FSO.GetBaseName(DocumentPath), 2)
  AccountNumber = Mid$(FSO.GetBaseName(DocumentPath), 3)
  Set CustomerDocumentsDirectory = FSO.GetFolder(CustomerDocumentsDirectoryPath)
  
  Set CustomerDirectory = FindCustomerFolder(SurnamePrefix, AccountNumber, CustomerDocumentsDirectory)
  
  If CustomerDirectory Is Nothing Then
    DestinationDirectoryPath = NewCustomerDocumentsDirectoryPath
  Else
    DestinationDirectoryPath = CustomerDirectory.Path
  End If
  
  FSO.MoveFile DocumentPath, FSO.BuildPath(DestinationDirectoryPath, FSO.GetFileName(DocumentPath))
 
    
 
End Sub
 
Function FindCustomerFolder(SurnamePrefix As String, AccountNumber As String, CustomerDocumentsDirectory As Object) As Object
 
Dim Folder As Object 'Scripting.Folder
Dim SurnameGroupFolder As Object 'Scripting.Folder
  
  'Loops through each Surname-Group Folder Alphabetically
  For Each Folder In CustomerDocumentsDirectory.SubFolders 'Subfolders are the GroupFolders followed by the Actual Customer's Directory
  
    'Stop once we've found a folder that is "greater than" the surname (Case Insensitive)
    If StrComp(Left$(Folder.Name, 2), SurnamePrefix, vbTextCompare) = 1 Then
      Exit For
    End If
    
    Set SurnameGroupFolder = Folder
  Next Folder
  
  'Search through the SurnameGroupFolder for a folder that matches the account number
  For Each Folder In SurnameGroupFolder.SubFolders
    If Folder.Name Like "*[#]" & AccountNumber Then
      Set FindCustomerFolder = Folder
      Exit Function
    End If
  Next Folder
 
End Function
 
Thanks again AlphaFrog, I tried the macro today and the good thing is that it actually did work! I was very happy to see this, but it does give a
run-time error '58': File already exists

The patients do have multiple files in the folders, so if they are all called the same then there are going to be duplicates. The scanner can add a random number + date (hrs, mins, secs) of scanned, but I don't want to use that, because the numbers run together with the account number and the macro will probably accidentally grab some of the random numbers.

If there a command that tells a file to keep both? Like automatically adding a (2) to the new file, then (3), (4), etc...?
 
Upvote 0

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
This will enumerate duplicate file names.

Code:
Sub Move_Patient_PDF_Files()
    
    Dim fsoFile As Object, counter As Long, i As Long
    Dim strFileName As String, DestinationPath As String
    Dim SurnamePrefix1 As String, SurnamePrefix2 As String
    Dim AccountNumber As String, GroupFolder As String, CustFolder As String
    
    Const ScannerDocsPath As String = "C:\Users\MIS\Documents\MACRO TEST\ScannerDocs"
    Const CustomerDocumentsPath As String = "C:\Users\MIS\Documents\MACRO TEST\CustomerDocs"
    Const NewCustomerDocumentsPath As String = "C:\Users\MIS\Documents\MACRO TEST\NewCustomers"
    
    With CreateObject("Scripting.FileSystemObject")
    
        'loop through each file in scanner folder
        For Each fsoFile In .GetFolder(ScannerDocsPath).Files
           If LCase(fsoFile.Name) Like "*.pdf" Then
            
                'Parse Surname letters and account number from file name
                SurnamePrefix1 = Mid$(fsoFile.Name, 1, 1)       'Surname 1st letter
                SurnamePrefix2 = Mid$(fsoFile.Name, 2, 1)       'Surname 2nd letter
                AccountNumber = Mid$(.GetBaseName(fsoFile), 3)  'Account number
                
                'Define Surname subgroup folder e.g.; Aa-Al or Am-Az
                If Asc(UCase(SurnamePrefix2)) < 77 Then 'test if 2nd letter is between A-L
                    GroupFolder = SurnamePrefix1 & "a-" & SurnamePrefix1 & "l"
                Else                                    'else the 2nd letter is between M-Z
                    GroupFolder = SurnamePrefix1 & "m-" & SurnamePrefix1 & "z"
                End If
                GroupFolder = CustomerDocumentsPath & "\" & GroupFolder & "\"
                
                'Find folder based on exact Account number
                CustFolder = Dir(GroupFolder & "*#" & AccountNumber, vbDirectory)
                If CustFolder <> "" Then    'Test if exact account number folder found
                    DestinationPath = GroupFolder & CustFolder & "\"
                Else
                    DestinationPath = NewCustomerDocumentsPath & "\"
                End If
                
                'if duplicate file name, enumerate file name
                i = 1
                strFileName = fsoFile.Name
                If Dir(DestinationPath & strFileName) <> "" Then
                    Do
                        i = i + 1
                        strFileName = .GetBaseName(fsoFile) & " (" & i & ").pdf"
                    Loop Until Dir(DestinationPath & strFileName) = ""
                End If
                
                'Move file
                .MoveFile fsoFile, DestinationPath & strFileName
                counter = counter + 1   'Count files
            
            End If
        Next fsoFile
    End With
    
    MsgBox counter & " files moved. ", , "Move Customer PDF Files Complete"
    
End Sub
 
Upvote 0
Thanks for the help! Sorry for the late reply! It seems to work perfectly fine as far as I can tell (there was the minor fact that I forgot to mention some letters that aren't used as often, like I, Q, X, Y, Z, etc...just had one folder, not two, but I just made two folders of each so the code could work with them). The only thing I have to do now is wait for the IT team to approve of it. This is the main reason I picked VBA is because it's not third-party, we already had Excel. If I had picked, say Java or C++, I'm sure they would have denied it, being a hospital and having HIPPA regulations, etc...

Anyway, thanks again and I'll try to keep you informed if they approve! :)


This will enumerate duplicate file names.

Code:
Sub Move_Patient_PDF_Files()
    
    Dim fsoFile As Object, counter As Long, i As Long
    Dim strFileName As String, DestinationPath As String
    Dim SurnamePrefix1 As String, SurnamePrefix2 As String
    Dim AccountNumber As String, GroupFolder As String, CustFolder As String
    
    Const ScannerDocsPath As String = "C:\Users\MIS\Documents\MACRO TEST\ScannerDocs"
    Const CustomerDocumentsPath As String = "C:\Users\MIS\Documents\MACRO TEST\CustomerDocs"
    Const NewCustomerDocumentsPath As String = "C:\Users\MIS\Documents\MACRO TEST\NewCustomers"
    
    With CreateObject("Scripting.FileSystemObject")
    
        'loop through each file in scanner folder
        For Each fsoFile In .GetFolder(ScannerDocsPath).Files
           If LCase(fsoFile.Name) Like "*.pdf" Then
            
                'Parse Surname letters and account number from file name
                SurnamePrefix1 = Mid$(fsoFile.Name, 1, 1)       'Surname 1st letter
                SurnamePrefix2 = Mid$(fsoFile.Name, 2, 1)       'Surname 2nd letter
                AccountNumber = Mid$(.GetBaseName(fsoFile), 3)  'Account number
                
                'Define Surname subgroup folder e.g.; Aa-Al or Am-Az
                If Asc(UCase(SurnamePrefix2)) < 77 Then 'test if 2nd letter is between A-L
                    GroupFolder = SurnamePrefix1 & "a-" & SurnamePrefix1 & "l"
                Else                                    'else the 2nd letter is between M-Z
                    GroupFolder = SurnamePrefix1 & "m-" & SurnamePrefix1 & "z"
                End If
                GroupFolder = CustomerDocumentsPath & "\" & GroupFolder & "\"
                
                'Find folder based on exact Account number
                CustFolder = Dir(GroupFolder & "*#" & AccountNumber, vbDirectory)
                If CustFolder <> "" Then    'Test if exact account number folder found
                    DestinationPath = GroupFolder & CustFolder & "\"
                Else
                    DestinationPath = NewCustomerDocumentsPath & "\"
                End If
                
                'if duplicate file name, enumerate file name
                i = 1
                strFileName = fsoFile.Name
                If Dir(DestinationPath & strFileName) <> "" Then
                    Do
                        i = i + 1
                        strFileName = .GetBaseName(fsoFile) & " (" & i & ").pdf"
                    Loop Until Dir(DestinationPath & strFileName) = ""
                End If
                
                'Move file
                .MoveFile fsoFile, DestinationPath & strFileName
                counter = counter + 1   'Count files
            
            End If
        Next fsoFile
    End With
    
    MsgBox counter & " files moved. ", , "Move Customer PDF Files Complete"
    
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,176
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top