'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

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

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

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

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