Microsoft Office Forums - View Single Post - Combining more than one line of the same item into one line

dopey · 02-22-2023, 09:31 AM

Hi Andrew, thanks for your help again. Unfortunately, it still did the same thing. However, with some of your code and some I found online, I have put together a macro that should do everything I want. It's a bit messy I'm afraid. I am a novice at this.

Basically, the whole macro should go through a main list, and anywhere there is a # symbol next to a line of text, it should take that line and paste it (in bold), into a new document.

Then it should take all the instances where there are 2 or more of each item and combine them into one. The only way I could figure out how to do this, was to add these below the first list (in normal font). Then I have a macro that will remove all the text in bold, which means only the 'concatenated' list will remain.

It works when I run the macros separately, however, when I run them altogether, it does not work.

Here is what I have so far:
Your help is so gratefully received.

Code:

Sub MyList()

    Dim oDoc As Document, oTarget As Document
    Dim oRng As Range, oPara As Range
    Set oDoc = ActiveDocument
    Set oTarget = Documents.Add
    Set oRng = oDoc.Range

    With oRng.Find
        Do While .Execute(FindText:="#")
           oRng.MoveEndWhile Chr(32)
           Selection.Font.Bold = True
           Set oPara = oRng.Paragraphs(1).Range
           oTarget.Range.InsertAfter (Trim(Replace(oPara.Text, "#", "")))
           oRng.Text = ""
           oRng.Collapse 0
        Loop
    End With

    Set oPara = Nothing
    Set oRng = Nothing
    
    Call ArrangeList
    Call DeleteList
    
    Set oTarget = Nothing

End Sub

Sub ArrangeList()
    Dim r As Range

    Set r = ActiveDocument.Range
    If (r.Characters.Last.Text = vbCr) Then r.End = r.End - 1
    SortList r
End Sub

Function SortList(r As Range)
    Dim sWrd As String
    Dim Found As Boolean
    Dim N As Integer, i As Integer, j As Integer, k As Integer, WordNum As Integer
    N = r.Words.Count
    ReDim Freq(N) As Integer
    ReDim Words(N) As String
    Dim temp As String

    i = 1
    WordNum = 0
    Do While r.Find.Execute(FindText:="<*>", MatchWildcards:=True, Wrap:=wdFindStop) = True
        If i = N Then Exit Do
            Found = False
            For j = 1 To WordNum
                If Words(j) = r.Text Then
                    Freq(j) = Freq(j) + 1
                    Found = True
                    Exit For
                End If
            Next j
        If Not Found Then
            WordNum = WordNum + 1
            Words(WordNum) = r.Text
            Freq(WordNum) = 1
        End If
        i = i + 1
    Loop

    Set r = ActiveDocument.Range
    Selection.Font.Bold = False

    r.Collapse wdCollapseEnd
    r.InsertParagraphAfter
    r.Collapse wdCollapseEnd

    r.InsertAfter "New List:"
    r.Collapse wdCollapseEnd
    r.InsertParagraphAfter
    r.Collapse wdCollapseEnd

    For j = 1 To WordNum
        r.InsertAfter Freq(j) & " x " & Words(j) & vbCr
    Next j

End Function
Sub DeleteList()
Dim oRng As Range, oRngE As Range
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Font.Bold = True
    While .Execute
      Set oRngE = oRng.Duplicate
      oRngE.End = ActiveDocument.Range.End
      With oRngE.Find
        .Font.Bold = True
        If .Execute Then
          oRngE.Start = oRng.Start
          oRngE.Delete
        End If
      End With
      oRng.Collapse wdCollapseEnd
    Wend
  End With
lbl_Exit:
  Exit Sub
End Sub