Archive Files Based on Partial File Name(Date Information)

[Kloria]

Hi! I am really new to VBA and had to trying to figure out my question in two weeks. Any help would be much appreciated!

I need to merge multiple word documents in FolderA into one document (either doc or pdf, doesn't matter) and then print it. (Print step can be done manually if can't be done through vba.) When merging the word documents, it needs to start with a new page every time (page break.) ---I have done this successfully with word vba but not through excel vba.

After the merging step, I need to archive the word documents into different folders based on the date information in the file name. The format of the filename is A_001_03012020.docx. I need to read the "03012020" information from the file name and then move this file to a new folder called "Completed.03012020". This new folder should contain every file with data"03012020" in file name in the original FolderA. ---In my word vba, I can move all the printed files into one new-created-folder, but can't move them distinguishably based on the date information in the file name.

If the file name is not easy to extract and use, created date will work in my case as well. The process of archive into different new-created-folder(if the folder already exists, just simply move into) based on the date information is the most critical and complex part. Thank you again for your kindly help!!

 

[Rijnsent]

Hi Kloria,
welcome to the forum! You forgot to post the code you already have, maybe accompanied by some pseudo-code, as that will help helping you massively. Could you add that here?
Thanks!
Koen

 

[Kloria]

Hi Kloria,
welcome to the forum! You forgot to post the code you already have, maybe accompanied by some pseudo-code, as that will help helping you massively. Could you add that here?
Thanks!
Koen

Hi Koen, thank you so much for your reply! Please see below of some of my codes.

My original word vba codes can help with merging/move files into a new folder:

Sub MergeFilesInAFolderIntoOneDoc()
  Dim dlgFile As FileDialog
  Dim objDoc As Document, objNewDoc As Document
  Dim StrFolder As String, strFile As String
  Set dlgFile = Application.FileDialog(msoFileDialogFolderPicker)
  With dlgFile
    If .Show = -1 Then
      StrFolder = .SelectedItems(1) & "\"
    Else
      MsgBox ("No folder is selected!")
      Exit Sub
    End If
  End With
  strFile = Dir(StrFolder & "*.docx", vbNormal)
  Set objNewDoc = Documents.Add

  While strFile <> ""
    Set objDoc = Documents.Open(FileName:=StrFolder & strFile)
    objDoc.Range.Copy
    objNewDoc.Activate
    With Selection
      .Paste
      .InsertBreak Type:=wdPageBreak
      .Collapse wdCollapseEnd
    End With
    objDoc.Close SaveChanges:=wdDoNotSaveChanges
    strFile = Dir()
  Wend

  objNewDoc.Activate
  Selection.EndKey Unit:=wdStory
  Selection.Delete
Set fs = CreateObject("Scripting.FileSystemObject")
Dim path As String
path = " \Proccessed."
MkDir path & Format((Year(Now() + 1) Mod 100), "20##") & _Format((Month(Now() + 1) Mod 100), "0#") & _Format((Day(Now()) Mod 100), "0#") &_Format((Hour(Now()) Mod 100), "0#") & _Format((Minute(Now()) Mod 100), "0#")
fs.CopyFile " \*.docx", path & Format((Year(Now() + 1) Mod 100), "20##") & _Format((Month(Now() + 1) Mod 100), "0#") & _Format((Day(Now()) Mod 100), "0#") & _
Format((Hour(Now()) Mod 100), "0#") & _Format((Minute(Now()) Mod 100), "0#")
fs.DeleteFile " \*.docx"
End Sub

I had some sample codes, which are also what I learned from the posts here in the forum to help with the archive process. (Much appreciated!) But the codes are either incomplete/not working functionally. I really need help with the archive process -- archive each file to a folder based on the date info:

Check_Files "file path"
Function Return_SubDirectory_Name(FileName As String) As String
        Dim Splitter() As String
    If Len(FileName) > 0 Then
        Splitter = Split(FileName, " _ ")
        If UBound(Splitter) = 2 Then
            Splitter = Split(Splitter(2), ".")
            Return_SubDirectory_Name = CStr(Splitter(0))
        Exit Function
        End If
        Return_SubDirectory_Name = vbNullString
   End If
End Function

Sub Check_Files(Search_Path As String
    Dim File_Name As String
    Dim File_Type As String 
    Dim strFileName As String
    Dim Deal_Name As String
    Dim Archive_Path As String
    Dim Target_Path As String
    Dim File_Count As Integer
    Archive_Path = "Archive Path"
    Confirm_Directory Search_Path
    ChDir Search_Path
   File_Type = Search_Path & "*.docx"
    strFileName = Dir(File_Type)
    Do While Len(strFileName) > 0
        Deal_Name = Return_SubDirectory_Name(strFileName)
        If Len(Deal_Name) > 0 Then
            Target_Path = Archive_Path & "\" & Deal_Name
            Confirm_Directory Target_Path       
            FileCopy Search_Path & "\" & strFileName, Target_Path & "\" & strFileName
            Kill Search_Path & "\" & strFileName       
            File_Count = File_Count + 1
        End If
        strFileName = Dir
    Loop
    Debug.Print "Moved " & File_Count & " file(s)"
End Sub

Sub Confirm_Directory(This_Path As String)
    Dim Splitter() As String
    Dim Test_Path As String
    If Dir(This_Path, vbDirectory) <> vbNullString Then
        Splitter = Split(This_Path, "\")
        For I = LBound(Splitter) To UBound(Splitter)
            If I = 0 Then
                Test_Path = Splitter(0)
            Else
                Test_Path = Test_Path & "\" & Splitter(I)
            End If
ReTest:
            If Dir(Test_Path, vbDirectory) = vbNullString Then
                'Debug.Print "'" & Test_Path & "' does not exist"
                MkDir Test_Path
                'Debug.Print "Making ' " & Test_Path & "'"
                GoTo ReTest
            Else
                'Debug.Print "'" & Test_Path & "' exists"
            End If
        Next I
    End I
End Sub

Thank you in advance for any help!!!!!!!!!!