CODEWITHSUNDEEP
vbams-word
Nolemonkey
Nolemonkey

Reputation: 159

VBA to read input from a file

I am trying to modify the following code, it will merge the Word Documents fine, but I have text file with every line being "*Name*.docx" "*Name2*.docx", etc, I would like the VBA macro to read the text file line by line and merge all the documents that match the pattern, should be 27 documents when done and save each one preferably with the a title that includes the "*Name" tag so I can know which is which. Any help would be greatly appreciated

Sub MergeDocs() 
Dim rng As Range 
Dim MainDoc As Document 
Dim strFile As String 
Const strFolder = "C:\test\" 
Set MainDoc = Documents.Add 
strFile = Dir$(strFolder & "*Name*.docx") 
Do Until strFile = "" 
    Set rng = MainDoc.Range 
    rng.Collapse wdCollapseEnd 
    rng.InsertFile strFolder & strFile 
    strFile = Dir$() 
Loop 
MsgBox ("Files are merged")

End Sub

Upvotes: 1

Views: 756

Answers (1)

dbmitch
dbmitch

Reputation: 5386

I think it's just a matter of adding an extra loop that reads the input file line by line and then uses your loop above.

This example uses the scripting filesystemobject to open the file and read it.

I assume what you've said above is what you actually mean - and the file spec is in the text file. Change the constants to fit your needs

Sub MergeDocs()

    Const FOLDER_START  As String = "C:\test\" ' Location of inout word files and text file
    Const FOLDER_OUTPUT As String = "C:\test\output\" ' send resulting word files here

    Const TEST_FILE     As String = "doc-list.txt"

    Dim rng             As Range
    Dim MainDoc         As Document

    Dim strFile         As String
    Dim strFileSpec     As String
    Dim strWordFile     As String

    Dim objFSO          As Object   ' FileSystemObject
    Dim objTS           As Object   ' TextStream

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strFile = FOLDER_START & TEST_FILE
    If Not objFSO.FileExists(strFile) Then
        MsgBox "File Doesn't Exist: " & strFile
        Exit Sub
    End If

    Set objTS = objFSO.OpenTextFile(strFile, 1, False) 'The one was ForReading but for me it threw an error
    While Not objTS.AtEndOfStream

        Set MainDoc = Documents.Add

        ' Read file spec from each line in file
        strFileSpec = objTS.ReadLine ' get file seacrh spec from input file

        'strFileSpec = "*NAME2*"
        strFile = Dir$(FOLDER_START & strFileSpec & ".docx") ' changed strFolder to FOLDER_START
        Do Until strFile = ""
            Set rng = MainDoc.Range
            rng.Collapse wdCollapseEnd
            rng.InsertFile FOLDER_START & strFile ' changed strFolder again
            strFile = Dir$() ' Get next file in search
        Loop

        strWordFile = Replace(strFileSpec, "*", "") ' Remove wildcards for saving filename
        strWordFile = FOLDER_OUTPUT & strWordFile & ".docx"
        MainDoc.SaveAs2 strWordFile
        MainDoc.Close False
        Set MainDoc = Nothing
    Wend

    objTS.Close
    Set objTS = Nothing
    Set objFSO = Nothing

    MsgBox "Files are merged"

End Sub

Upvotes: 1

Related Questions