Создание именованного диапазона на основе строковых значений EXACT в ячейке

Question

У меня есть следующий код, который просматривает значения, которые у меня есть в столбце C. Когда он находит слово «Поиск», код создает именованный диапазон под названием «Поиск» для столбцов с D по 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

Однако, хотя в Name Manager это выглядит нормально, когда я использую VBA для преобразования диапазона в таблицу в слове, кажется, что он вставляет ВСЕ значения, где слово «Поиск» находится в столбце C. Примечание, в столбце CIимеют различные значения ячеек, такие как «Отчетность», «Поиск», «Поиск и фильтр», «Поиск и анализ» и т. д. Таким образом, диапазон, который вставляется в слово, кажется, включает строки из «Поиск и ..»."клетки тоже.

Это код, который я использую для экспорта в закладку в слове ...

  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

Любая помощь, как всегда, очень ценится!

Answer 1

Проблемы, наблюдаемые в коде

1. для открытия нового документа в слове попробуйте что-то вроде `Set myDoc = Wordapp.Documents.Add '
2. Не знаю, что такое DoesNameRangeExist, если это какая-то подпрограмма, которая не создается в коде
3. Имя рассматриваемого NamedRange - "QuBuild", но вы использовали имя "Поиск"

Попробуйте следующую модификацию, чтобы она заработала (как проверено мной на работе).

Добавить ссылку на библиотеку объектов Microsoft Word XX

в разделе объявлений

Dim Nm As Name
Dim Wordapp As Word.Application
Dim myDoc  As Word.Document

Наконец, в последнем разделе

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

Редактировать: Однако в ходе испытаний было замечено, что метод PasteExcelTable копирует все смежные строки между несмежными рядами диапазонов объединения. Можно сослаться на SO Post , однако ответ в посте не решает проблему и, наконец, прибегает к длинному пути ниже для правильной работы. Пригласите и сделайте все возможное, чтобы узнать больше Простые решения для непосредственного копирования пасты Union Union из Excel в Word от экспертов.

Код:

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