Move Selection to the next Column on a Page (Not a table)

[GuitarForLife]

Hi, Ive written some code which changes the colour of certain selected text.


The page of each document has either one or two columns. The documents are only one page long.
The code works beautifully as it moves down the first column of text, but wont move up to the top of the second column to start editing that piece of text.
I cant find any code that identifies the number of columns, and then moves the selection from the bottom of the first column (when it gets there), to the top of the second column so it can start the process again.

Appreciate your help!

Here is my code:

Sub ColourText()
Dim numOfLines As Integer
Dim numOfColumns As Integer
Dim numOfSpaces As Integer
Dim numOfChar As Integer
Dim ArraySpaces() As String
Dim x1 As Integer


'Count the number of non blank lines in current document
numOfLines = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES")


'Move to start of document
Selection.HomeKey Unit:=wdStory

'Start the loop - looping once for each line
For x1 = 1 To numOfLines

'Move to start of line
Selection.HomeKey Unit:=wdLine

'Select entire line
Selection.EndKey Unit:=wdLine, Extend:=wdExtend


If Len(Selection.Range.Text) > 1 Then 'if 1 ignore as paragraph return only

'check to see if current line is likely to be Chords - ie if it contains lots of spaces
ArraySpaces = Split(Selection.Range.Text, " ")
numOfSpaces = UBound(ArraySpaces)

'count characters in selection
numOfChar = Len(Selection.Range.Text) - numOfSpaces

If (numOfSpaces > numOfChar) Or numOfChar < 4 Then ' likely not to be text so should be chords
'colour this line blue
Selection.Font.TextColor.RGB = RGB(0, 0, 255)
Else 'colour this line black
Selection.Font.TextColor.RGB = RGB(0, 0, 0)
End If
End If

If InStr(1, Selection.Range.Text, "Chorus") Then
Selection.Range.HighlightColorIndex = wdYellow
Selection.Font.Bold = True
End If

'Move to the next part of the loop ##but wont do this when more than 1 column of text

Selection.MoveDown Unit:=wdLine, count:=1

Next x1

MsgBox ("Setup completed")

End Sub

[gmayor]

'Lines' are a vague concept in Word, especially in a document that is dynamically formatted and doubly so when there are columns.

I won't pretend to know what your document looks like and so I can't test your macro to see what it does in practice, but as you have discovered, moving down by lines ignores the presence of a second column of text and continues to the next page. You need to move right to move the next column.

I suppose you could test whether the page has changed each time you move down and then move back and move right to the start of the next column (that will also take you to the start of the next page) e.g. as follows but whether it will work in the context of your macro is hard to ascertain

'Move to the next part of the loop ##but wont do this when more than 1 column of text
        iPage = Selection.Information(wdActiveEndPageNumber)
        Selection.MoveDown Unit:=wdLine, Count:=1
        If Selection.Information(wdActiveEndPageNumber) > iPage Then
            Selection.MoveUp Unit:=wdLine, Count:=1
            Selection.EndKey Unit:=wdLine, Extend:=wdExtend
            Selection.MoveRight Unit:=wdCharacter
        End If

[GuitarForLife]

Thanks Graham. From your response I gather there is no way to tell what the bottom line of the first column is? I have included an example of a document if that helps further.

My numOfLines variable tells me the aggregate number of lines in both columns accurately, but I would prefer to use a loop that redirected to Selection.MoveRight Unit:=wdCharacter, once I hit the bottom of the first column.

Thanks

[kilroy]

Guitar, this is what I use for my sheet music. Not perfect but does a lot of the work. You can add more chords. I'm sure one of the guys could simplify it.

Sub ChangeColorTargets()
Dim range As range
Dim i As Long
Dim TargetList
 
TargetList = Array("A  ", "Am", "E7", "A#", "A7", "Ab", "B ", "Bm ", "B7", _
"C ", "Cm ", "D ", "Dm ", "E ", "Em ", " C", "C#", "Db", "D#", "E#", "Eb", "Fb", " F", "F#", "Gb", " G ", "G#", "Ab", "B#", "Bb")
'... Add additional words to this line at the end, each word to be separated with , "[WORD]"
' if you run out on the second line, end it with , "[WORD]" _ and continue on next line
 
For i = 0 To UBound(TargetList)
Set range = ActiveDocument.range
With range.Find
.Text = TargetList(i)
.Format = True
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute(Forward:=True) = True
range.Font.TextColor.RGB = RGB(0, 0, 255)
Loop
End With
Next
Call HighlightTargets
End Sub
Sub HighlightTargets()
Dim range As range
Dim i As Long
Dim TargetList
 
TargetList = Array("[Chorus]", "[Verse]", "[Bridge]", "[Solo]")
'... Add additional words to this line at the end, each word to be separated with , "[WORD]"
' if you run out on the second line, end it with , "[WORD]" _ and continue on next line
 
For i = 0 To UBound(TargetList)
Set range = ActiveDocument.range
With range.Find
.Text = TargetList(i)
.Format = True
.MatchCase = True
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute(Forward:=True) = True
range.HighlightColorIndex = wdYellow
Loop
End With
Next
 
End Sub

[GuitarForLife]

Hi Kilroy thanks for your thoughts- seems we have similar tastes! The problem for me is that I use every conceivable chord variation incl diminished, sus, half diminished, 6ths etc etc and therefore would be having potentially 100+ chord variations in the targetlist array. Instead of using that technique I've found that I can identify which line has chords, and which has lyrics through a ratio of spaces to total characters in the line. Works like a treat as I separate my chords with spaces. I'll try using your approach re setting range as this is where my code is going wrong as it won't find the second column.
Have you written any code for transposing? Love to see it if you have thanks?
Recently my computer crashed and I lost my 'tricky' code for transposing, and formatting, as the location for saving macros was not being backed up - very frustrating as all my docs etc are religiously backed up. Didn't realise they were kept in some obscure folder separate to the actual document.

[kilroy]

I thought about using spaces and the following code works for that but there are instances where even the lyric lines have many spaces at the start of the line like in the chorus the line "Yeah I love....". If you were to use tab and no more than 3 spaces to align lyrics with chords and use tabs for spacing the Title then the following works. Also keep in mind that the code looks for 4 spaces so when you have sections like "Solo" or "Bridge" where you only list the chords and don't need to align with lyrics those types of progressions need to have at least one place where you use 4 spaces in a row.

This is a temporary fix until you figure out the ratio thing, which is way above me. Looking forward to seeing the solution.

Also I'm very interested in the transposing code you spoke of.

Sub ChordFont()
    Dim oRng As range
    Set oRng = ActiveDocument.range
    With oRng.Find
        Do While .Execute(FindText:="    ")
            oRng.Start = oRng.Sentences(1).Start
            oRng.End = oRng.Paragraphs(1).range.End
            oRng.Font.TextColor.RGB = RGB(0, 0, 255)
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
 
      Call HighlightChorus
      Exit Sub
End Sub
Sub HighlightChorus()
    Dim oRng As range
    Set oRng = ActiveDocument.range
    With oRng.Find
        Do While .Execute(FindText:="[Chorus]")
            oRng.Start = oRng.Sentences(1).Start
            oRng.End = oRng.Paragraphs(1).range.End
            oRng.HighlightColorIndex = wdYellow
            oRng.Collapse 0
        Loop
    End With
lbl_Exit:
    Set oRng = Nothing
    Exit Sub
 
End Sub

[kilroy]

Check this version out.

Sub ColourText2()
Dim numOfLines As Integer
Dim numOfColumns As Integer
Dim numOfSpaces As Integer
Dim numOfChar As Integer
Dim ArraySpaces() As String
Dim x1 As Integer
With Selection.PageSetup.TextColumns
        .SetCount NumColumns:=1
        .EvenlySpaced = True
        .LineBetween = False
End With

'Count the number of non blank lines in current document
numOfLines = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES")

'Move to start of document
Selection.HomeKey Unit:=wdStory
Selection.WholeStory
'Start the loop - looping once for each line
For x1 = 1 To numOfLines
'Move to start of line
Selection.HomeKey Unit:=wdLine
'Select entire line
Selection.EndKey Unit:=wdLine, Extend:=wdExtend

If Len(Selection.Range.Text) > 1 Then 'if 1 ignore as paragraph return only
'check to see if current line is likely to be Chords - ie if it contains lots of spaces
ArraySpaces = Split(Selection.Range.Text, " ")
numOfSpaces = UBound(ArraySpaces)
'count characters in selection
numOfChar = Len(Selection.Range.Text) - numOfSpaces
If (numOfSpaces > numOfChar) Or numOfChar < 4 Then ' likely not to be text so should be chords
'colour this line blue
Selection.Font.TextColor.RGB = RGB(0, 0, 255)
Else 'colour this line black
Selection.Font.TextColor.RGB = RGB(0, 0, 0)
End If
End If
If InStr(1, Selection.Range.Text, "Chorus") Then
Selection.Range.HighlightColorIndex = wdYellow
Selection.Font.Bold = True
End If
'Move to the next part of the loop ##but wont do this when more than 1 column of text
Selection.MoveDown Unit:=wdLine, Count:=1
'Selection.Columns.Select
Next x1
With Selection.PageSetup.TextColumns
        .SetCount NumColumns:=2
        .EvenlySpaced = True
        .LineBetween = False
        .Width = InchesToPoints(3.49)
End With
MsgBox ("Setup completed. Rock on Bud!")
End Sub

[macropod]

IMHO, this would be a lot simpler if you used Styles for the formatting. As far as I can tell, too, you don't need any complicated arrays. Try:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrTmp As String: Const StrAcc As String = "m7#b"
On Error Resume Next
With ActiveDocument
  .Styles.Add "Chord", wdStyleTypeParagraph 'wdStyleTypeCharacter
  .Styles("Chord").Font.ColorIndex = wdBlue
End With
On Error GoTo 0
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<[A-F][m7#b ^13]"
    .Replacement.Text = ""
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
    If .Paragraphs(1).Style = "Chord" Then
      .End = .Paragraphs(1).Range.End
    Else
      StrTmp = Split(.Paragraphs(1).Range.Text, vbCr)(0)
      For i = 1 To Len(StrAcc)
        StrTmp = Replace(StrTmp, Mid(StrAcc, i, 1), "")
      Next
      For i = 1 To 7
        StrTmp = Replace(StrTmp, Chr(64 + i), "")
      Next
      StrTmp = Trim(StrTmp)
      If StrTmp = "" Then .Paragraphs(1).Style = "Chord"
    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[[!\[]@\]"
    .Replacement.Text = ""
    .Wrap = wdFindStop
    .Format = False
    .MatchWildcards = True
    .Execute
  End With
  Do While .Find.Found
      Select Case .Text
        Case "[Chorus]": .HighlightColorIndex = wdYellow: .Style = wdStyleStrong
        Case "[Verse]": .HighlightColorIndex = wdNoHighlight: .Font.Reset
        Case "[Bridge]": .HighlightColorIndex = wdBrightGreen: .Style = wdStyleStrong
      End Select
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
Application.ScreenUpdating = True
End Sub