Найдите неизвестное имя и фамилию в открытом документе Word, скопируйте его и вставьте в ячейку A12 в Excel .activesheet с Excel VBA

Question

Hello Stackoverflow community.

Моя цель - написать макрос, который находит неизвестное имя (или оба имени, написанные так, как "Имя Имя"), и фамилию (или обе фамилии, написанные так, как "Firstsurname-Secondsurname" ) в ранее открытом / активном документе Word - на компьютере будет открыт только один документ Word. Я хочу найти и скопировать имя и фамилию из пункта 2.

Затем макрос должен скопировать это имя и вставить его в ячейку A12 в файле .actives excel. Только одна книга Excel будет открыта на компьютер в то время в пункте 1. = "REGON 364061169, NIP 951-24-09-783,". Это перед именем + фамилией, которую я хочу найти и скопировать - надеюсь, это поможет.

Но также и текст "2 , «непосредственно перед именем + фамилией я хочу скопировать, и хотя во всем контракте строка» 2. «появляется более 20 раз, это 1-й» 2. "вхождение, предшествующее имени + фамилии, которое я хочу скопировать и вставить в ячейку Excel.

Имя + фамилия постоянно изменяется, неизвестно и каждый раз имеет разное количество слов / символов.

Sub FindNames()
    'Variables declaration
    Dim WordApp As Word.Application
    Dim WordDoc As Word.Document
    Dim ExcelApp As Excel.Application
    Dim MySheet As Worksheet

    Dim TextToFind As String
    Dim FirstName As String
    Dim Rng As Word.Range
    Dim StartPos As Long
    Dim EndPos As Long
    Application.ScreenUpdating = False

    TextToFind = "REGON 364061169, NIP 951-24-09-783,"             'this text length is 21 caracters

    'Assigning object variables
    Set WordApp = GetObject(, "Word.Application")
    Set ExcelApp = GetObject(, "Excel.Application")
    Set WordDoc = WordApp.ActiveDocument
    Set MySheet = Application.ActiveWorkbook.ActiveSheet
    'Set MySheet = ExcelApp.ActiveWorkbook.ActiveSheet
    Set Rng = WordApp.ActiveDocument.Content

    'InStr function returns a Variant (Long) specifying the position of the _
     first occurrence of one string within another.
    StartPos = InStr(1, Rng, TextToFind)          'here we get 1420, we're looking 4 "TextToFind"
    EndPos = InStr(StartPos, Rng, "§ 1. ")        'here we get 2742, we're looking 4 ",00zł"

    If StartPos = 0 Or EndPos = 0 Then
        MsgBox ("Client's names were not found!")
    Else
        StartPos = StartPos + Len(TextToFind)     'now start position is reassigned at 1455;
        FirstName = Mid(Rng, StartPos, EndPos - StartPos)

    End If
    'len(Firstname)
End Sub

Это лучшее, что я могу написать, но я не могу выделить только имя + фамилию из большой переменной = FirstName.

Мой версия кода, предоставленная @PeterT, которая не работает для меня.

Rng.SetRange Start:=StartPos, End:=EndPos
    Debug.Print Rng.Paragraphs.Count

    If StartPos = 0 Or EndPos = 0 Then
        MsgBox ("Client's names were not found!")
    'finding the paragraphs that follow the TextToFind1
    Else
        For Each Para In Rng.Paragraphs
         'how to identify the second paragraph?
         'these are not .ListParagraphs, they're normal paragraphs  
         'If Para.Range.ListParagraphs.Count = 1 Then
            If Para.Range.Paragraphs.Count = 2 Then
               'how to access the second paragraph?
               'If Para.Range.ListFormat.ListValue = 2 Then
               'Para.Range.Paragraphs(1).Next(Count:=1).Range
               'If Para.Range.Paragraphs.Count = 2 Then
                Debug.Print "Name = " & Para.Range.Words(1) & _
                            ", Surname = " & Para.Range.Words(2)
            End If
        Next Para
    End If

Я не могу получить доступ ко второму абзацу и извлечь строку "Michał Łukasz ROESLER".

I ' Я также хотел бы извлечь "Katarzyna Paula STANISZKIS-KRAWCZYK" из третьего абзаца в Rng. Оба они находятся на первой странице документа.

Answer 1

Лучший способ сделать это - создать Word.Range, выполнить поиск в диапазоне, а затем настроить его для захвата имен.

Dim srchRng as Word.Range
Dim thisDoc as Word.Document: Set thisDoc = Word.ActiveDocument

Set srchRange = thisDoc.Content
With srchRange.Find
    .Text = "REGON 364061169, NIP 951-24-09-783,"
    .Execute
    If .Found = True Then
        srchRange.MoveEndUntil Cset:="."
        srchRange.MoveEnd wdWord, 3

        If srchRange.Words.Last.Next.Text = "-" Then
            srchRange.MoveEnd wdWord, 2
        End If

        Dim nameStart As Long
        nameStart = InStr(1, srchRange.Text, "2. ")
        Dim fullName As String
        fullName = Mid(srchRange.Text, nameStart + 3)
    End If
End With


Debug.Print fullName

Answer 2

Этот ответ намеренно отделен от моего предыдущего примера. Этот другой пример основан на поиске абзацев, отформатированных как ListParagraphs, и остается действительным, если ваш поиск должен включать этот стиль форматирования.

Этот ответ предполагает, что пронумерованные абзацы являются просто обычными абзацами (хотя и с отступом и пронумерованы). В этом примере проверка ошибок не выполняется, например, если> абзац не пронумерован или имена расположены в другом месте абзаца.

Установив searchRange описанным ниже способом, вы заверил, что первый абзац содержит ваш поисковый запрос. В данном случае это абзац для элемента 1. Поскольку searchRange определяется с помощью поискового термина, вы уверены, что имя находится в следующем абзаце. Нет необходимости в l oop.

Option Explicit

Sub FindNames2()
    Dim textToFind As String
    textToFind = "REGON 364061169, NIP 951-24-09-783,"

    Dim searchArea As Word.Range
    Set searchArea = ThisDocument.Content

    Dim startPos As Long
    Dim endPos As Long
    startPos = InStr(1, searchArea, textToFind)
    If (startPos = 0) Then Exit Sub

    '--- adjust the area to start from where we found the text
    '    until the end of the document
    searchArea.SetRange Start:=startPos, End:=searchArea.End

    '--- we want the name at the start of the very next paragraph
    '    (the current paragraph with the text to find is paragraph 1)
    Dim theParagraph As Word.Paragraph
    Set theParagraph = searchArea.Paragraphs(2)

    Dim itemNumber As Long
    Dim firstName As String
    Dim lastName As String
    itemNumber = CLng(Trim(theParagraph.Range.Words(1)))
    firstName = Trim$(theParagraph.Range.Words(3))
    lastName = Trim$(theParagraph.Range.Words(4))

    Debug.Print "Name = " & firstName & " " & lastName & " in Item #" & itemNumber
End Sub

Несколько замечаний из дополнительного примера в OP.

1. endPos может быть нулем, даже если поиск текст найден. Мое тестирование показало, что проверки startPos было достаточно.
2. Например, при обращении к Word(3) возвращенный текст может иметь пробел на одной или обеих сторонах слова. Использование функции Trim$ удаляет этот пробел.
3. Вы можете получить доступ к имени в следующем абзаце, увеличив его с Paragraphs(2) до Paragraphs(3).

.

Answer 3

В этом примере кода предполагается, что вы выполняете макрос из документа MS Word.

Option Explicit

Sub FindNames()
    Dim textToFind As String
    textToFind = "REGON 364061169, NIP 951-24-09-783,"

    Dim searchArea As Word.Range
    Set searchArea = ThisDocument.Content

    Dim startPos As Long
    Dim endPos As Long
    startPos = InStr(1, searchArea, textToFind)
    If startPos = 0 Then Exit Sub

    '--- adjust the area to start from where we found the text 
    '    until the end of the document
    searchArea.SetRange Start:=startPos, End:=searchArea.End

    '--- now find the list paragraphs that follow the text
    Dim para As Word.Paragraph
    For Each para In searchArea.Paragraphs

        '--- identify the list paragraph
        If para.Range.ListParagraphs.Count = 1 Then

            '--- find the second item in the list
            If para.Range.ListFormat.ListValue = 2 Then
                Debug.Print "Name = " & para.Range.Words(1) & _
                            ", Surname = " & para.Range.Words(2)
            End If
        End If
    Next para

End Sub