Hi, I have a relatively straightforward problem but have been unsuccessful at solving it so far.
I would like to transfer data from Word to Excel. The information in Word exists in the exact same format a few thousand times:
Quote:
Cake description:•
This is a description of a nice cake.¶
Blue¶
Color¶
Striped¶
Pattern¶
Ice frosting¶
Decoration¶
Cake description:•
This is a description of a second cake.¶
Green¶
Color¶
Lines¶
Pattern¶
Chocolate rice¶
Decoration¶
Cake description:•
This is a description of a third cake.¶
<some text to be ignored>¶
Pink¶
Color¶
Stars¶
Pattern¶
Hundreds and thousands¶
Decoration¶
|
The dataset is completely uniform in this regard. All three properties are always present in the exact same order with the exact same line break/paragraph break at the end. There is a new line/paragraph break at the end of every cake, but not at the end of description.
I have indicated the paragraph marks as this affects the VBA code used. I would like to iteratively append the data into an Excel sheet, as such:
I attempted to take inspiration from
https://www.msofficeforums.com/word-...paragraph.html but did not get far. The code was able to get the Cake description, but I could not delete the words "Cake description:". I also thought of using
Code:
Selection.Previous(unit:=wdParagraph, Count:=1).Select
to select the Color, Pattern, and Decoration, but was not able to get the syntax right. I have attached a sample input .docx and output .xlsx.
My best attempt was this, but it did not work:
Code:
Sub Demo()
Application.ScreenUpdating = False
Dim strFnd As String, DocSrc As Document, DocTgt As Document
strFnd = InputBox("What is the Text to Find")
If Trim(strFnd) = "" Then Exit Sub
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
With DocSrc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strFnd
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
Selection.Previous(unit:=wdParagraph, Count:=1).Select
DocTgt.Characters.Last.FormattedText = .Paragraphs(1).Range.FormattedText
.End = .Paragraphs(1).Range.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
I would love any kind of help. Thanks in advance!