Creating a named range based on EXACT string values in a cell - excel

Question

I have the following code that goes through values that I have in column C. When it finds the word "Search", the code creates a named range called "Search" for columns D to F.
Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Features")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
counter = 0 'this counter will help us avoid Union(Nothing, some range), which would give an error
For Each cell In featuresRng 'loop through the range of features
If cell.Value = "Query Builder" Then
counter = counter + 1
If counter = 1 Then
Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
Else
Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
End If
End If
Next cell
Debug.Print rng.Address
ThisWorkbook.Names.Add "QuBuild", rng
However, whilst it appears fine on the Name Manager, when I use VBA to transition the range into a table in word, it seems to paste ALL values where the word "Search" is in column C.
Note, in column C I have a variety of cell values such as "Reporting", "Search", "Search and Filter", "Search and Analyse" etc. So, the range that is pasted into word appears to include the rows from the "Search and.." cells too.
This is the code I am using to export to a bookmarked position in word...
On Error Resume Next
Set WordApp = GetObject(class:="Word.Application")
'Clear the error between errors
Err.Clear
If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
WordApp.Visible = True
WordApp.Activate
'Create a New Document
Set myDoc = WordApp.Documents.Open("Doc1")
'Copy Excel Table Range
'Copy and Paste Search into MS Word
If DoesNameRangeExist("Search") = True Then
Search.Copy
myDoc.Bookmarks("Search").Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
End If
Any help is, as always, much much appreciated!

Answer 1

The issues observed in the code
for opening New document in the word try something like `Set myDoc = Wordapp.Documents.Add'
Don't know what is DoesNameRangeExist, if is some sub routine the that is not produced in the code
The name of the NamedRange in question is "QuBuild" but you have used Name "Search"
Try following modification to make it work (as tested by me to work).
Add reference to Microsoft Word XX Object Library
in declaration section
Dim Nm As Name
Dim Wordapp As Word.Application
Dim myDoc As Word.Document
Finally in last section
Set myDoc = Wordapp.Documents.Add
For Each Nm In ThisWorkbook.Names
If Nm.Name = "QuBuild" Then
Nm.RefersToRange.Copy
Debug.Print Nm.RefersToRange.Address
myDoc.Bookmarks.Add "Search", myDoc.Range
myDoc.Range.PasteExcelTable False, False, False
Exit For
End If
Next Nm
Edit: However on trial it was observed that PasteExcelTable method is copying all the adjacent rows in between union ranges non-adjacent rows. May refer to the SO Post however answer in the post does not solve the problem and finally resorted to lengthy way below for correct operation. Invite & eager to learn more Simple Solutions to directly copy paste Union range from excel into Word from experts.
Code:
Set myDoc = Wordapp.Documents.Add
Dim RngtoCopy As Range
Dim xArea As Range, Rw As Range, col As Long, Tbl As Table
Dim TotalRow As Long
'If both the section of code are in the same procedure
'then it is not be necessary to use next loop to find NamedRange
'And can be directly refer as Rng.Areas instead of RngtoCopy.Areas
For Each Nm In ThisWorkbook.Names
If Nm.Name = "QuBuild" Then
Set RngtoCopy = Nm.RefersToRange
Exit For
End If
Next Nm
Set Tbl = myDoc.Tables.Add(myDoc.Range, 1, 3)
TotalRow = 0
For Each xArea In RngtoCopy.Areas
For Each Rw In xArea.Rows
TotalRow = TotalRow + 1
If TotalRow > Tbl.Rows.Count Then Tbl.Rows.Add
col = 0
For Each cell In Rw.Columns
col = col + 1
Tbl.cell(TotalRow, col).Range.Text = cell.Value
Next
Next
Next