How to write a macro to amalgamate date

[Pete]

MS Word Office XP
I have a long (single column) list of records containing variable items.
Each item sublist begins e.g., Record number: 1, Record number 2
Each item sublist ends with a unique sys.no. e.g. sys.no. 002286060

I am successfully transposing this into a set of records in MS Access but it
is dependent on each heading appearing only once in each Sublist. It is a
list of book details.

The problem I have is that the heading of some items is repeated – e.g.,
Notes: A publication of the Merton foundation
Notes: Includes bibliographical references
ISBN: 1594710899
ISBN: 9781594710926 (v. 3)
ISBN: 9781594710919 (v. 4)

Could someone possibly write a macro that I could adapt to join e.g., all
the Notes together in one line / sentence and all the ISBN data in one line /
sentence. The heading in each case – Notes / ISBN – only needs to be stated
once.

Since I have many thousands of such records to transpose a shove in the
right direction would be immensely appreciated. Thanks

 

[larrysulky]

Quick and dirty, with assumed hardcoded consistency on the record
leaders. This won't work if you need to join any adjacent records that
start with the same set of characters no matter what they are.

You might need to prep the leaders to ensure consistent format, and on
output, you might want to fiddle with the semicolons and spaces etc.

--larry

'''''''''''''''''''''''''''''''''''''''''
Sub JoinLikeRecords()

Dim myFlagContinue As Boolean
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With

Selection.HomeKey Unit:=wdStory
myFlagContinue = True
Do While myFlagContinue
With Selection.Find
.Text = "(ISBN: ^s ^s[!^013]@)^013ISBN: ^s ^s"
.Replacement.Text = "\1; "
End With
myFlagContinue =
(Selection.Find.Execute(Replace:=wdReplaceAll))
Loop

Selection.HomeKey Unit:=wdStory
myFlagContinue = True
Do While myFlagContinue
With Selection.Find
.Text = "(Notes: ^s [!^013]@)^013Notes: ^s "
.Replacement.Text = "\1; "
End With
myFlagContinue =
(Selection.Find.Execute(Replace:=wdReplaceAll))
Loop

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " ;"
.Replacement.Text = ";"
End With
Selection.Find.Execute Replace:=wdReplaceAll

End Sub

 

[David Sisson]

OK I'll take a stab.

Using ranges...

Counter = 2
do
Search for "Record Number 1" '(Rng1)

Search for "Record Number " & Counter '(Rng2)
If Rng2 is nothing then Rng2 = activedocument.range.content.end

Rng3 = Range(Rng1, Rng2)

For Each Para in Rng3.Paragraphs

StringFound = InStr(Para, "Notes:")
If StringFound > 1 then
MyNotes = MyNotes & right(Para, len(Para - StringFound) & ", ")
end if

StringFound = InStr(Para, "ISBN:")
If StringFound > 1 then
MyISBN = MyISBN & right(Para, len(Para - StringFound) & ", ")
end if

next Para

Write new record somewhere. Access, another file, ....

Counter = Counter + 1

loop until Rng2.end = Activedocument.range.content.end

Pretty rough, but should get you started.

 

[Pete]

Thanks for this so far. Testing has brought to light another factor - on
occasion the duplicate ISBN line is separated from the other(s) by a
completely different heading. I provide an example to illustrate this
clearly. This particular list has >250 books. Others have up to 500. Is it
possible to amend the VB to take this into consideration? To make things
simpler I have eliminated the duplicate Notes so as to focus on one item at a
time. Thanks. Sorry this is so complex.

Record number : 15
Format BK
LC Control No. 2006033696
ISBN 9781933495057
ISBN 1933495057
LC Call No. BV 4832.3 .M47 2007
Dewey Decimal Call 242/.2 22
ME-Personal Name Merton, Thomas, 1915-1968.
Title A book of hours / Thomas Merton ; edited by Kathleen
Deignan ; illustrations by John Giuliani ; with a foreword by Jim Finley.
Pub. Dist., etc. (I Notre Dame, IN : Sorin Books, 2007.
Sys.No. 002261762

Record number : 16
Format BK
LC Control No. 85023864 //r92
ISBN 0814604064 (pbk.)
ISBN 0800619129 (Fortress Press : pbk.)
LC Call No. BS1430.2 .M445 1986
Dewey Decimal Call 248.3 19
ME-Personal Name Merton, Thomas, 1915-1968.
Title Bread in the wilderness / Thomas Merton.
Phys.Description 179 p. ; 18 cm.
ISBN 0814604063 (hbk.)
Bibliography Note Bibliography: p. 174-179.##
Sys.No. 001337151

 

[Russ]

Pete,

I didn't know how your data was formatted.
So this macro starts off by changing any soft returns into paragraph marks.
Then it concatenates the ISBN and Notes lines.
But I didn't test with tab formatting. Well placed vbTab characters could
make it output with tabs.
I had to lose some of the pretty indenting so that copy and paste of this
code would work more reliably.

Sub JoinISBNandNotes()
Dim recordRange As Word.Range
Dim docRange As Word.Range
Dim placeholderRange As Word.Range
Dim workString As String

Application.ScreenUpdating = False
Set docRange = ActiveDocument.Content
With docRange.Find
.MatchWildcards = True
.Text = "^l"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "^13"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "<Record*Sys.No."
.Replacement.Text = "^&"
Do While .Execute = True
Set recordRange = docRange.Duplicate
With recordRange.Find
.Text = "<ISBN*^13"
.MatchWildcards = True
.Execute
If .Found Then
Set placeholderRange = ActiveDocument.Range( _
Start:=recordRange.Start, End:=recordRange.Start)
workString = Trim(Mid(recordRange.Text, 6, _
Len(recordRange.Text) - 7))
recordRange.Delete
recordRange.SetRange Start:=recordRange.End, End:=docRange.End
Do While .Execute = True
workString = workString & " -And- " & Trim(Mid( _
recordRange.Text, 6, Len(recordRange.Text) - 7))
recordRange.Delete
recordRange.SetRange Start:=recordRange.End, _
End:=docRange.End
Loop
'insert & vbTab & after the second quote character, if needed
placeholderRange.InsertAfter "ISBN " & workString & vbCr
End If
End With
Loop
End With
Set docRange = ActiveDocument.Content
With docRange.Find
.MatchWildcards = True
.Text = "<Record*Sys.No."
.Replacement.Text = "^&"
Do While .Execute = True
Set recordRange = docRange.Duplicate
With recordRange.Find
.Text = "<Notes*^13"
.MatchWildcards = True
.Execute
If .Found Then
Set placeholderRange = ActiveDocument.Range( _
Start:=recordRange.Start, End:=recordRange.Start)
workString = Trim(Mid(recordRange.Text, 7, _
Len(recordRange.Text) - 8))
recordRange.Delete
recordRange.SetRange Start:=recordRange.End, End:=docRange.End
Do While .Execute = True
workString = workString & " -And- " & Trim(Mid( _
recordRange.Text, 7, Len(recordRange.Text) - 8))
recordRange.Delete
recordRange.SetRange Start:=recordRange.End, _
End:=docRange.End
Loop
'insert & vbTab & after the second quote character, if needed
placeholderRange.InsertAfter "Notes " & workString & vbCr
End If
End With
Loop
End With
Application.ScreenUpdating = True
End Sub

 

[Russ]

Pete,
If the ISBN and Notes is clipped too much, lower the number that is
subtracted in each Trim() function. You want to get from the Trim()
function, all the number or note except the last character, which would be
the paragraph mark.