Loop through Word files and paste data from corresponding Excel sheets

[JohnHarveyCH]

Hello good people of the Internet, I hope you can help save my sanity as I've been working on this for a while now to no avail!

I have a lot of Word files in a folder. These are named "Blue 1", "Blue 2", "Blue 3" etc. I have data that is stored in corresponding Excel files one folder down the structure (eg in "Sessions" contained in my main folder), each named "1", "2", "3" etc with variable-length data in them that needs to be pasted into the Word files.

My question is, how can I get a macro to open each Word file, open the corresponding numbered Excel file, grab all the data that's in there and paste it into my Word folder? I also have the data-to-be-pasted in a big list also containing my 1, 2, 3 "session codes" if that can be used rather than the individual files.

I create the Word files also from individual Excel files, running a macro that will create individual mailmerged DOCXs from everything that's in a specific folder. My thinking is that code to paste in data from other excel files could be included in this sub?

Sub PlanMerge()

    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    
    'Declare the variables
    Dim objFSO As FileSystemObject
    Dim objFolder As Folder
    Dim objFile As File
    Dim strPath As String
    Dim intResult As Integer
    Dim venue
    
    venue = "Blue" 'find Excel files with Blue in the name
    
    With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    strPath = .SelectedItems(1)
    End With
    
    'Specify the path to the folder

    
    'Create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Get the folder
    Set objFolder = objFSO.GetFolder(strPath)
    
    'If the folder does not contain files, exit the sub
    If objFolder.Files.Count = 0 Then
        MsgBox "No files were found...", vbExclamation
        Exit Sub
    End If
    
    'Turn off screen updating
    Application.ScreenUpdating = False
    
    'Loop through each file in the folder
    For Each objFile In objFolder.Files
    
If InStr(objFile.Name, venue) Then
    
'opens file and relevant sheet
    ActiveDocument.MailMerge.OpenDataSource Name:=objFile _
        , ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
        AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
        WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
        Format:=wdOpenFormatAuto, Connection:="" _
        , SQLStatement:="SELECT * FROM `Sheet1$`", SQLStatement1:="", SubType:= _
        wdMergeSubTypeAccess
    
'mail merge options
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        .Execute Pause:=False
    End With
    
'excel data added here?

'save
    ChangeFileOpenDirectory strPath
    ActiveDocument.SaveAs2 FileName:=objFile & ".docx", _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
    ActiveDocument.Close

End If

    Next objFile
    
    'Turn screen updating back on
    Application.ScreenUpdating = True
        
End Sub

 

[JohnHarveyCH]

Further to this, I'm now trying an approach where instead of copying the data from multiple Excel files into Word files, I'll use a masterlist of the Excel data instead. Therefore the Sub that I'm currently working on is in Excel, after I've used the Sub above to make my original Word Files. My problem now is amending the Sub below to do what I need - at each change of the reference number in Column A, copy all those cells containing the same reference (eg A6:H9, or A10:H12 or A329:H344) into Word. Here is what I have so far (shamelessly stolen from Excel legend Doug Robbins):

Sub copystuff()

Dim WordApp As Object
Dim WordDoc As Object
Dim WordWasNotRunning As Boolean
Dim i As Long

On Error Resume Next
Set WordApp = GetObject(, "Word.Application")

If Err Then
Set WordApp = New Word.Application
WordWasNotRunning = True
End If

With Worksheets(3).Range("A5") 'data is on third worksheet, header starts on row 5

    For i = 1 To .CurrentRegion.Rows.Count
    Set WordDoc = WordApp.Documents.Open([Path] & "\Blue " & .Offset(i, 0) & ".xlsx.docx") 'this works and can find the DOCX files well
        'this seems to be code that doesn't work for me and needs replacing
        WordDoc.Range.InsertBefore .Offset(i, 1) & vbCr & .Offset(i, 2) & vbCr & .Offset(i, 3) & vbCr & .Offset(i, 0) & vbCr 
    WordDoc.Save
    WordDoc.Close
Next i
End With

If WordWasNotRunning = True Then
WordApp.Quit
End If

Set WordApp = Nothing
Set WordDoc = Nothing

End Sub