Hello Stackoverflow community.
The code I need your help with, finds and extracts the counterparts names/surnames from the beginning of the word document, then it puts these names into a consecutive cells in Excel, for example "A12", "A13" and "A14". The word document looks like this:
The target Workbook that macro will write into looks like this:
The majority of the code works just fine but there is one thing I don't know how to achieve:
- The full name of the first counterparty found, in the example below it's "Jan STANEK" is not supposed to be written into the worksheet. Macro needs to start entering names from the full name of the second counterparty that's found in a way that: 2nd counterparty's name is written into cell "A12", 3rd counterparty's name is written into cell "A13" and 4th counterparty's name is written into cell "A14" and so on.
The end effect of the macro should be:
- "Jan STANEK" is not written anywhere in the worksheet, It's simply extracted while searching through the document but skipped during input to the worksheet phase,
- "Michal Lukasz ROESLER" is written into cell "A12",
- "Katarzyna Paula STANISZKIS-KRAWCZYK" is written into cell "A13",
- "Tomasz Leon Bogdan WISNIAK-STRYCZEWSKI"is written into cell "A14" and so on.
Sub FindNamesByRonRosenfeldWithInput()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim ExcelApp As Excel.Application
Dim MySheet As Excel.Worksheet
Dim Para As Word.Paragraph
Dim Rng As Word.Range
Dim pStart As Long
Dim pEnd As Long
Dim Length As Long
Dim TextToFind1 As String
Dim TextToFind2 As String
Dim firstName As String
Dim fullName As Word.Range
Dim startPos As Long
Dim endPos As Long
Dim x As Long
Application.ScreenUpdating = False
'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
TextToFind1 = "REGON 364061169, NIP 951-24-09-783,"
TextToFind2 = "- ad."
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
If startPos = 0 Or endPos = 0 Then
MsgBox ("Client's names were not found!")
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
End Sub