Macro to bring Excel data into Word template

[andreamehre]

I'm having trouble with the below Macro. This is used to find information in an excel worksheet and use that info to fill in a word template. We used this in the past (2019ish) and it ran just fine, but now I either get a "Run Time Error 5852," or it just crashes Word. I ran the debugger and the bolded line seems to be causing this. I've tried linking the excel file as the MailMerge source, but that didn't work either. I didn't write this and I'm pretty new to macros, so I'm not sure how else to trouble shoot this.

Sub Outage
Dim dsMain As MailMergeDataSource, Ticker As String
Ticker = InputBox("Enter the Ticker:")
With ActiveDocument.MailMerge.DataSource
    Do While .FindRecord(FindText:=Ticker, Field:="Ticker") = True
        If .DataFields("Ticker") = Ticker Then
            numRecord = .ActiveRecord
            Exit Do
        End If
    Loop
End With
End Sub

[Aussiebear]

Hi andreamehre, welcome to VBAX. Someone with word experience will hopefully be along shortly to assist you . When posting code to this forum, can you please use code tags to wrap your code, as in. [ Code]... your code... [ /Code] but without the spaces. One of the original members (Mark007), very kindly wrote some specialised code to help layout submitted code to make it easier to read. Thank you.

[andreamehre]

Hello! I will definitely do that in the future, thank you!

[gmayor]

The basic concept of the code appears to work correctly. There are some issues to check.
1. Is the merge document still a letters merge document and connected to the data source? (check with 'Edit recipient list' from the Mailings tab of the ribbon)
2. Is the Ticker field name correctly spelled. Note the code is case sensitive. (again check with 'Edit recipient list')
3. The variable numRecord is not declared. This shouldn't be an issue, but it is good practice to declare all variables.
Add

Dim numRecord As Long

to the top of the code below the existing Dim statement.
However, testing here, the code is not exactly reliable and has no error handling so while sitting around waiting for my broadband connection to be installed I spent the time messing around to produce a faster and more reliable result. See how you get on with the following. It requires that there are no empty fields in the data source.

Option Explicit

Sub Outage()
'Graham Mayor - https://www.gmayor.com - Last updated - 10 May 2023
Dim sValue As String
Dim sTicker As String
Dim sWB As String
Dim arr() As Variant
Dim iRows As Long, iCol As Long
Dim bFound As Boolean
Const sField As String = "Ticker" 'The name of the field (case sensitive)
Const sSheet As String = "Sheet1" 'The name of the worksheet (case sensitive)
   
   sTicker = InputBox("Enter the Ticker:")
   If sTicker = "" Then Exit Sub
    
    With ActiveDocument.MailMerge.DataSource
        
        sWB = .Name
        If sWB = "" Then
            MsgBox "The data source is missing?", vbCritical
            Exit Sub
        End If
   
        iCol = xlGetColumn(sWB, sSheet, sField)
        
        arr = xlFillArray(sWB, sSheet)
        
        For iRows = 0 To UBound(arr, 2)        ' Second array dimension is columns.
            sValue = arr(iCol, iRows)
            If sValue = sTicker Then
                .ActiveRecord = iRows + 1
                bFound = True
                Exit For
            End If
        Next iRows
        If bFound = False Then
            MsgBox sTicker & " not found", vbInformation
            Exit Sub
        End If
    End With
lbl_Exit:
    Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
                             strRange As String) As Variant
'Graham Mayor - http://www.gmayor.com - 24/09/2016
Dim RS As Object
Dim CN As Object
Dim iRows As Long

    strRange = strRange & "$]"    'Use this to work with a named worksheet
    'strRange = strRange & "]" 'Use this to work with a named range
    Set CN = CreateObject("ADODB.Connection")

    'Set HDR=NO for no header row
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function

Private Function xlGetColumn(ByVal strWorkbook As String, _
                             strRange As String, _
                             sField As String) As Long
'Graham Mayor - https://www.gmayor.com - Last updated - 10 May 2023
'unsorted
Dim i As Long

    strRange = strRange & "$]"
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
    Set RS = CreateObject("ADODB.Recordset")
    RS.CursorLocation = 3

    RS.Open "SELECT * FROM [" & strRange, CN, 2, 1        'read the data from the worksheet
    
    For i = 0 To RS.Fields.Count - 1
        If RS.Fields(i).Name = sField Then
            xlGetColumn = i
            Exit For
        End If
    Next i

lbl_Exit:
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
    Exit Function
End Function

[Aussiebear]

Graham, with the FindText:= Ticker, does the Ticker need to in Quotation marks?

[gmayor]

No = it's a variable. It should be sTicker ?

[andreamehre]

Thank you for the quick response and the code!! I'll work through this and let you know if I find any errors I can't correct on my own.