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
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