Formatting content between headings into two columns

[sbrbot]

I've got a Word document with the following content;

Heading level 1
Heading level 2
Heading level 3
A text paragraph that should be formatted (including Headings of 3rd level)
Heading level 3
A text paragraph that should be formatted (including Headings of 3rd level)
Heading level 3
A text paragraph that should be formatted (including Headings of 3rd level)
Heading level 2
Heading level 3
A text paragraph that should be formatted (including Headings of 3rd level)
Heading level 3
A text paragraph that should be formatted (including Headings of 3rd level)
Heading level 1
Heading level 2
Heading level 3
A text paragraph that should be formatted (including Headings of 3rd level)

I need a macro which would pass through this whole document content and format content of text paragraphs (including Headings of level 3) colored red into two columns. Of course, there's no constant number of paragraphs inside Headings and there's no constant number lower level headings inside upper level headings.

How to do that?

[macropod]

Hi sbrbot,

So what code have you got so far and which parts do you need help with?

[sbrbot]

OK, this is my code. It works. It formats Heading 3 content in two equal columns.


Sub FormatH3ContentIntoColumns()

Dim lineNo As Long ' line number
Dim rangeStart As Long ' range start point
Dim rangeEnd As Long ' range end point
Dim rangeObj As range ' range object

' goto the beginning of document text
Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1

Do
' start counting lines
lineNo = Selection.range.Information(wdFirstCharacterLineNumber)
Selection.MoveDown Unit:=wdLine, Count:=1

' find a line with H3
If Selection.Style = ActiveDocument.Styles(wdStyleHeading3) Then
' this is start of text range that should be columned
rangeStart = Selection.Start

' proceed until next H2, H1 or EOF found
Do
lineNo = Selection.range.Information(wdFirstCharacterLineNumber)
Selection.MoveDown Unit:=wdLine, Count:=1
rangeEnd = Selection.Start
Loop Until Selection.Style = ActiveDocument.Styles(wdStyleHeading2) _
Or Selection.Style = ActiveDocument.Styles(wdStyleHeading1) _
Or lineNo = Selection.range.Information(wdFirstCharacterLineNumber)
' if we reached next H2,H1 or EOF this is end of text range that should be columned

Set rangeObj = ActiveDocument.range(Start:=rangeStart, End:=rangeEnd)
' if one wants columns of text segment it should be separated by continuous breaks
rangeObj.InsertBreak Type:=wdSectionBreakContinuous
Selection.InsertBreak Type:=wdSectionBreakContinuous
' format it into two equal columns
With rangeObj.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
.Width = CentimetersToPoints(7.5)
.Spacing = CentimetersToPoints(1)
End With
End If

Loop While lineNo <> Selection.range.Information(wdFirstCharacterLineNumber)

End Sub


As you can see from this code, I test if I reached the end of file (EOF) by comparing if current line number of cursor is the same with the line number after I try to move to next line (Section.MoveDown). There has to be more elegant way for this!?

Can you suggest any other way for looping through document line by line and exit from loop when EOF is reached?

[macropod]

Hi sbrbot,

You might like to give this a try:
Public Sub ColumnFormat()
Dim oPara As Paragraph
Dim StartRng As Range
Dim EndRng As Range
Dim oSctn As Section
Application.ScreenUpdating = False
With ActiveWindow
If .View.SplitSpecial <> wdPaneNone Then .Panes(2).Close
If .ActivePane.View.Type <> wdPrintView Then .ActivePane.View.Type = wdPrintView
End With
With ActiveDocument
With .PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
.Spacing = CentimetersToPoints(1)
End With
For Each oPara In .Paragraphs
If oPara.Style.NameLocal = "Heading 1" And Len(Trim(oPara.Range.Text)) > 1 Or _
oPara.Style.NameLocal = "Heading 2" And Len(Trim(oPara.Range.Text)) > 1 Then
Set StartRng = oPara.Range
StartRng.Collapse (wdCollapseStart)
Set EndRng = oPara.Range
EndRng.Collapse (wdCollapseEnd)
StartRng.InsertBreak Type:=wdSectionBreakContinuous
EndRng.InsertBreak Type:=wdSectionBreakContinuous
oPara.Range.PageSetup.TextColumns.SetCount NumColumns:=1
End If
Next oPara
For Each oSctn In .Sections
If Len(Trim(oSctn.Range.Text)) = 1 Then oSctn.Range.Delete
Next
End With
Application.ScreenUpdating = True
End SubThe above code starts off by formatting the whole document with a two-column layout, then reformats just the Headings 1 & 2 as single column.

[sbrbot]

That's really interesting approach to format the whole document in two columns and after that to format only Headings of first and second level into one column. This could work in sample give above but not in my real document because real documents (which could contain shown sample) also contain many other elements like title, TOC etc. But, what to say, thanks for your effort.

Using Application.ScreenUpdating in order to turn off screen updating during macro execution seems to be good praxis, so I'll accept it as well. Contrary to that, I think that hardcoding heading names "Heading 1" and "Heading 2" in test clasue is not good praxis because this code will not work on my croatian localized Microsoft Word (since our local heading names are different) but code using Word constants wdStyleHeading will work. :-)

I also wanted to create my code using For Each loop because it seems more clear and object oriented way to me but I was not successful with it. I'm still not so familiar with Word DOM like in other languages (HTML is good example) but I'll learn it soon.

Finally what would be the code which would pass through the whole Word document line by line (not paragraph by paragraph) from the beginnng til the end?

[sbrbot]

There is one approach for looping through the whole document:

Do Until ActiveDocument.Bookmarks("\Sel") = ActiveDocument.Bookmarks("\EndOfDoc")
'(Do something)
Loop


This approach uses internal hardcoded Word document bookmarks but this is also dirty programming.

[macropod]

Hi sbrbot,

I took the approach I used because your post didn't indicate that the document had any material you wanted to treated differently. You need to be clear about your requirements. You could easily enough modify the code to work on only a selected or specified range.

As for the Heading Style names, I accept what you say as fair comment. Again, you could easily modify the code to work with wdStyleHeading1 and wdStyleHeading2.

As for your question about processing a document line, by line, you need to keep in mind that Word has a very flexible interpretation of what a line is. That's because Word uses the active printer's driver to determine the page layout. Consequently, the amount of test that fits on one line can vary from printer to printer, and even with the same printer if different drivers are used. So, with that in mind, here's some code to count the number of lines in a selection.
Sub GetLineCount()
Dim MyRange As Range, LineCount As Long
Set MyRange = Selection.Range
Selection.Collapse wdCollapseStart
While Selection.InRange(MyRange) = True
LineCount = LineCount + 1
Selection.MoveDown Unit:=wdLine, Count:=1
Wend
MyRange.Select
MsgBox LineCount
End Sub

[sbrbot]

Thanks macropod again,

I was thinking myself too about what the line of text is and have concluded that this is not easy to say what line really is (on A4 page line could be one thing and on Letter page it will be another thing, you already mentioned printer's driver page layout). Paragraph is strictly defined as text between CRs. Line cannot be so strictly defined. Good thing is that Headings are always separate paragraphs.

I created another code for formatting Heading 3 content into two columns using For Each paragraph loop:


Sub FormatH3ContentIntoColumns()

Dim para As Paragraph
Dim rStart As Long
Dim rEnd As Long
Dim rOpen As Boolean

Dim H1 As Style
Dim H2 As Style
Dim H3 As Style

Set H1 = ActiveDocument.Styles(wdStyleHeading1)
Set H2 = ActiveDocument.Styles(wdStyleHeading2)
Set H3 = ActiveDocument.Styles(wdStyleHeading3)

rOpen = False

For Each para In ActiveDocument.Paragraphs
' if current paragraph is H3 (and first after H1/H2)
If (para.Style = H3) And Not rOpen Then
rOpen = True ' range is open (has start/not end)
rStart = para.range.start ' start range
ElseIf ((para.Style = H1) Or (para.Style = H2)) And rOpen Then
rOpen = False ' range is closed (has start and end)
Call ColumnRange(rStart, rEnd) ' create range and column it
Else
rEnd = para.range.End ' add current paragraph in range
End If
' goto next paragraph
Next para

If rOpen Then
' if last range in doc (not closed by H1 or H2)
Call ColumnRange(rStart, rEnd) ' create range and column it
End If

End Sub

Private Sub ColumnRange(rStart As Long, rEnd As Long)
Dim rang As range
Set rang = ActiveDocument.range(start:=rStart, End:=rEnd)
rang.InsertBreak (wdSectionBreakContinuous)
ActiveDocument.range(start:=rEnd, End:=rEnd).InsertBreak Type:=wdSectionBreakContinuous
With rang.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
.Width = CentimetersToPoints(7.5)
.Spacing = CentimetersToPoints(1)
End With
End Sub

[macropod]

Hi sbrbot,

Just an observation: In your code you're setting both the column width and the spacing width. When you're using evenly-spaced columns and you want their outer margins to match the page margins, you need only set the spacing size.

[sbrbot]

Thanks, that's good hint.