@ michalroesler Приведенный ниже код будет искать диапазон в документе Word и возвращать файл scripting.dictionary, имя которого соответствует правилам 1. число находится в начале строки 2. имя заканчивается на запятая.
Похоже, это то, что используется в вашем документе.
Получив список, вы легко можете удалить имя или даже извлечь его, если вам нужно использовать его где-то еще.
В тестовом подпрограмме вы увидите, как выполнять итерацию по всем элементам в словаре сценариев. Исходя из этого, вам будет легко определить, как заполнить файл Excel.
2020-02-04 Редактировать на основе комментариев, сделанных ОП. Я обновил код ниже, чтобы выполнить полную задачу.
Мои причины для обновления кода в том, что я всегда чувствовал, что SO должен пытаться обучать одновременно с предоставлением ответов.
Код, предоставленный OP, показывает много проблем, которые можно аккуратно избежать, выделяя отдельные задачи. А именно
- Определение наличия диапазона поиска в исходном документе
- Сбор списка имен, соответствующих заданным c правилам компоновки
- Обработка имен в некоторых способ (в данном случае это просто удаление имени)
- Перенос имен на лист Excel в вертикальном столбце, начиная с именованной ячейки.
ОП попытался сделайте это в одной подпрограмме, что означает, что вы получите большую подпрограмму.
Обновленный код, который я предоставил, берет исходный код OP, повторяет предоставленный код, комментирует части исходного кода, которые больше не требуется и заменяет закомментированный код меньшими функциями, цель которых сосредоточена на одной задаче. Возможно, есть несколько мест, где можно использовать еще более мелкие функции.
Код был проверен надстройкой из резиновой утки fantasti c для VBA (отсюда и комментарии @Ignore). Проверка кода из RubberDuck - фантастическая c помощь в написании кода без ошибок.
Я проверил его на небольшом словесном документе, который создал с именами, соответствующими правилам, которые я вывел выше.
Я пытался показать хорошие практики, которые я изучил в прошлом году или около того из своего поиска в VBA проблем.
- Переменные объявляются в ближайшем безопасном месте, где они находятся первыми используемый. Это потому, что это значительно упрощает работу по рефакторингу кода с RubberDuck
- Длинные, более значимые имена. Я не знаю, что OP означает под переменной x, кто-нибудь еще?
- код работает в соответствующей среде. • Данные извлекаются из Word • Извлеченные данные обрабатываются в VBA • обработанные данные записываются обратно в Excel, потому что в этом случае задача, как объясняется в OP, поддается такой обработке.
Надеюсь, обновленный код более удовлетворителен для ОП.
Public Sub FindNamesByRonRosenfeldWithInput()
Const FirstName As Long = 1
'It would probably be better to padd TextToFInd1 & 2 as parameters to this function
'Dim TextToFind1 As String
Const TextToFind1 As String = "REGON 364061169, NIP 951-24-09-783,"
'Dim TextToFind2 As String
Const TextToFind2 As String = "- ad."
Dim WordApp As Word.Application
Set WordApp = GetObject(, "Word.Application")
Dim WordDoc As Word.Document
Set WordDoc = WordApp.ActiveDocument
'Dim Rng As Word.Range - used more expressive name
'Set Rng = WordApp.ActiveDocument.Content
Dim myNamesSearchRangeInWord As Word.Range
Set myNamesSearchRangeInWord = getSearchRangeInDocument(WordDoc, TextToFind1, TextToFind2)
myNamesSearchRangeInWord.Select
'If startPos = 0 Or endPos = 0 Then
If myNamesSearchRangeInWord Is Nothing Then
'@Ignore FunctionReturnValueDiscarded
MsgBox ("Client's names were not found!")
Exit Sub
End If
Dim myNames As Scripting.Dictionary
Set myNames = GetNumberedNames(myNamesSearchRangeInWord)
'@Ignore VariableNotUsed
Dim myNamesStr As Variant
myNamesStr = myNames.Items
'Delete the first name that we found from the list of names
myNames.Remove FirstName
myNamesStr = myNames.Items
'Dim firstName As String
'Dim fullName As Word.Range
' The fourth line below shows you are running in Excel so the next two lines are not needed
' because you already have the excel application object.
' Dim ExcelApp As Excel.Application
' Set ExcelApp = GetObject(, "Excel.Application")
Dim mySheet As Excel.Worksheet
Set mySheet = Application.ActiveWorkbook.ActiveSheet
'Dim Para As Word.Paragraph
'Dim pStart As Long
'Dim pEnd As Long
'Dim Length As Long
'Dim startPos As Long
'Dim endPos As Long
'Dim x As Long
Application.ScreenUpdating = False
'Assigning object variables
'x = 11
'InStr function returns a Variant (Long) specifying the position of the first occurrence of one string within another.
'startPos = InStr(1, Rng, TextToFind1) - 1 'here we get 1421, we're looking 4 "TextToFind1"
'endPos = InStr(1, Rng, TextToFind2) - 1 'here we get 2497, we're looking 4 "- ad."
'If startPos = 0 Or endPos = 0 Then Exit Sub
'Rng.SetRange Start:=startPos, End:=endPos
'Debug.Print Rng.Paragraphs.Count
'Else
'The full name of the first counterparty found, is not supposed to be written into the worksheet.
'It's not important and I just want to skip it.
'Macro needs to start entering names from the full name of the second counterparty that's found,
'in a way that: 2nd counterparty's full name is written into cell "A12", 3rd counterparty's full name is written into cell "A13",
'and 4th counterparty's full name is written into cell "A14" and so on.
' For Each Para In Rng.Paragraphs
' firstName = Trim$(Para.Range.Words(3))
' 'Debug.Print firstName
' pStart = InStr(Para, ".") + 1 'here we get 3
' Length = InStr(Para, ",") - pStart 'here we get 14/25/39 - 3
' Debug.Print Trim(Mid(Para, pStart, Length))
' x = x + 1
' Cells(x, 1).Value = Trim(Mid(Para, pStart, Length))
' Next Para
' End If
'transfer the remaining names to the excel worksheet in a single action
Dim myitems As Variant
myitems = myNames.Items
Dim myXlRange As Excel.Range
Set myXlRange = mySheet.Range("A13")
Set myXlRange = myXlRange.Resize(myNames.Count, 1)
myXlRange.Value = Application.WorksheetFunction.Transpose(myNames.Items)
End Sub
Public Function getSearchRangeInDocument(ByVal ipDoc As Word.Document, ByVal ipStartText As String, ByVal ipEndText As String) As Word.Range
With ipDoc.StoryRanges.Item(wdMainTextStory)
With .Find
.ClearFormatting
.Text = ipStartText
.Replacement.Text = vbNullString
.MatchWildcards = False
.Wrap = wdFindStop
If Not .Execute(Replace:=wdReplaceNone) Then Exit Function
End With
Dim mySearchRange As Word.Range
Set mySearchRange = .Duplicate
.Collapse Direction:=wdCollapseEnd
'@Ignore FunctionReturnValueDiscarded
.MoveStart Count:=1
If Not .Find.Execute(findtext:=ipEndText) Then Exit Function
mySearchRange.End = .End
End With
Set getSearchRangeInDocument = mySearchRange
End Function
Public Function GetNumberedNames(ByVal ipRange As Word.Range) As Scripting.Dictionary
Dim myEndOfSearchRange As Long
myEndOfSearchRange = ipRange.Document.StoryRanges.Item(wdMainTextStory).End
Dim myNames As Scripting.Dictionary
Set myNames = New Scripting.Dictionary
With ipRange
With .Find
.ClearFormatting
.Text = "(<)([0-9]{1,})(.)( {1,})([!,]{1,})"
.MatchWildcards = True
.Wrap = wdFindStop
End With
Do While .Find.Execute
' If it is likely that the loop will take a long time then put a DoEvents Statement here
myNames.Add getNumberFromRange(.Duplicate), getNameFromRange(.Duplicate)
.Collapse Direction:=wdCollapseEnd
'@Ignore FunctionReturnValueDiscarded
.MoveStart Count:=1
.End = myEndOfSearchRange
Loop
End With
Set GetNumberedNames = myNames
End Function
Public Function getNumberFromRange(ByVal ipRange As Word.Range) As Long
'@Ignore FunctionReturnValueDiscarded
ipRange.MoveStartUntil cset:="0123456789"
'@Ignore FunctionReturnValueDiscarded
ipRange.MoveEndUntil cset:=".", Count:=wdBackward
'@Ignore FunctionReturnValueDiscarded
ipRange.MoveEnd Count:=-1
getNumberFromRange = CLng(Trim$(ipRange.Text))
End Function
Public Function getNameFromRange(ByVal ipRange As Word.Range) As String
'@Ignore FunctionReturnValueDiscarded
ipRange.MoveStartUntil cset:="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
getNameFromRange = Trim$(ipRange.Text)
End Function