Combining more than one line of the same item into one line

dopey · #1 02-19-2023, 08:40 AM

Hi all,

I hope someone can help me with this. I have some code that looks for a specific symbol in a word document, and then paste that line into a new document. If there are e.g. 3 of the same symbol next to each other, it will copy the same line 3 times, e.g:

Sample list:
pen
book #
desk ###
pencil

It needs to paste the following into the new word document:
book
3 x desk

At the moment, it is writing the word 'desk' three times underneath each other. I have had some help putting the code together, but I am now stuck again on how to streamline it.

I hope it all makes sense.

Code:

This is the code I have so far:
    With oRng.Find
        Do While .Execute(findText:="#")
            oRng.MoveEndWhile Chr(32)
            Set oPara = oRng.Paragraphs(1).Range
            oTarget.Range.InsertAfter (Trim(Replace(oPara.Text, "#", "")))
            oRng.Text = ""
            oRng.Collapse 0
        Loop
    End With

Guessed · #2 02-19-2023, 07:00 PM

Try this method

Code:

Sub Get2DaChopper()
  Dim str As String, oRng As Range, arr() As String, i As Integer
  Set oRng = ActiveDocument.Range
  With oRng.Find
    Do While .Execute(findText:="#")
      arr = Split(oRng.Paragraphs(1).Range.Text, "#")
      For i = 1 To UBound(arr)
        str = str & arr(0) & vbCr
      Next i
     Set oRng = oRng.Paragraphs(1).Range
     oRng.Collapse Direction:=wdCollapseEnd
     oRng.End = ActiveDocument.Range.End
    Loop
  End With
  Debug.Print str
End Sub

dopey · #3 02-20-2023, 06:37 AM

Hi Andrew, thanks so much for the reply. Unfortunately, this saved an empty file.

This is my full code (with your addition):

Code:

Sub List()

    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
    
    Dim str As String, arr() As String, i As Integer
    Set oRng = ActiveDocument.Range
    With oRng.Find
      Do While .Execute(findText:="#")
        arr = Split(oRng.Paragraphs(1).Range.Text, "#")
        For i = 1 To UBound(arr)
          str = str & arr(0) & vbCr
        Next i
       Set oRng = oRng.Paragraphs(1).Range
       oRng.Collapse Direction:=wdCollapseEnd
       oRng.End = ActiveDocument.Range.End
      Loop
    End With
    Debug.Print str
    
    Set oDoc = Nothing
    Set oTarget = Nothing
    Set oRng = Nothing
    Set oPara = Nothing
    
    Dim DateStr, FileStr As String
    DateStr = Format(CStr(Now), "yyyy-mm-dd hh mm")
    FileStr = "List " & DateStr & ".docx"

        ChangeFileOpenDirectory "C:\Users\dopey\Documents\List\"
        ActiveDocument.SaveAs2 FileName:=FileStr, FileFormat:= _
        wdFormatXMLDocument
        ActiveDocument.Close
        Windows("List.docx").Activate

Dim intResponse As Integer
 
intResponse = _
 MsgBox("Do you want to save all documents?", vbYesNo)
 If intResponse = vbYes Then Application.Quit _
 SaveChanges:=wdSaveChanges, OriginalFormat:=wdWordDocument

End Sub

Guessed · #4 02-20-2023, 05:17 PM

My code was writing the list to a string variable called str. You need to place the contents of this string into the new document.

Try this version which creates the new doc and puts the contents into it.

Code:

Sub List()
  Dim oDoc As Document, oTarget As Document
  Dim oRng As Range, oPara As Range
  Dim str As String, arr() As String, i As Integer
  
  Set oDoc = ActiveDocument
  Set oRng = oDoc.Range
  With oRng.Find
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Text = "#"
    Do While .Execute = True
      Set oPara = oRng.Paragraphs(1).Range
      Debug.Print oPara.Text
      arr = Split(oPara.Text, "#")
      For i = 1 To UBound(arr)
        str = str & arr(0) & vbCr
      Next i
      oRng.Start = oPara.End
    Loop
  End With
  If str <> "" Then
    Set oTarget = Documents.Add
    oTarget.Range.Text = str    'put list into new unsaved doc
  End If
End Sub

dopey · #5 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

Guessed · #6 02-22-2023, 04:07 PM

The second macro I posted worked on a sample doc that I created.
Can you post a sample document that you are trying to process?

dopey · #7 02-22-2023, 06:20 PM

Please see my sample document. This is just a very basic document, trying to show what I'm trying to achieve.

Guessed · #8 02-22-2023, 07:56 PM

My code works fine with your sample doc so I'm not sure why you weren't getting it to work. Perhaps your intended doc wasn't the ActiveDocument when you were testing the code.

I added a couple of extra lines to sort the result and remove the empty paragraph that my code created.

Code:

Sub List()
  Dim oDoc As Document, oTarget As Document
  Dim oRng As Range, oPara As Range
  Dim str As String, arr() As String, i As Integer
  
  Set oDoc = ActiveDocument
  Set oRng = oDoc.Range
  With oRng.Find
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Text = "#"
    Do While .Execute = True
      Set oPara = oRng.Paragraphs(1).Range
      Debug.Print oPara.Text
      arr = Split(oPara.Text, "#")
      For i = 1 To UBound(arr)
        str = str & arr(0) & vbCr
      Next i
      oRng.Start = oPara.End
    Loop
  End With
  If str <> "" Then
    Set oTarget = Documents.Add
    oTarget.Range.Text = str    'put list into new unsaved doc
    oTarget.Range.Sort ExcludeHeader:=False
    oTarget.Range.Paragraphs(1).Range.Delete
  End If
End Sub

dopey · #9 02-24-2023, 10:56 AM

Hi Andrew, thanks again for your help. I have one last favour to ask.

Most things now work as I want, apart from if a line contains more than one word, e.g. if I have "Yellow Paper##", I want it to put down "2 x Yellow Paper". However, it puts down the following:
2 x Yellow
2 x Paper

The variable 'r' has the value "Yellow Paper", until it goes past this line in the code:

Code:

    Do While r.Find.Execute(FindText:="<*>", MatchWildcards:=True, Wrap:=wdFindStop) = True

As soon as I go past this point, 'r' changes to "Yellow". I've tried a lot of ways to fix it, but I cannot figure out what I'm doing wrong.

Here is the code I'm using:

Code:

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
        Selection.Font.Bold = False
        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

    r.Collapse wdCollapseStart
    r.Collapse wdCollapseEnd

    r.Font.Italic = True
    r.Collapse wdCollapseEnd
    
    r.InsertParagraphBefore
    r.Collapse wdCollapseEnd

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

End Function

Thanks again

Guessed · #10 02-26-2023, 05:59 PM

It appears you are over-engineering your solution. Have you worked out why the code I've provided doesn't work for you?

You don't need to sort an array of words if your paragraphs are going into an empty document, just sort that document by paragraph after populating it.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
1st line of 4-line poem centrally aligned; how to get lines 2-4 to start at same location on page	Swarup	Word	6	09-16-2022 11:07 AM
Making mail merge blank fill a line to highlight that line	rgm60527	Mail Merge	2	02-22-2022 11:13 AM
word erases line bottom in tight line spacing when new line is added	ozzzy	Word	2	01-21-2021 06:41 AM
Usability of space between final line of body text and footnote separator line	Swarup	Word	6	07-28-2018 12:51 PM
Combining IMAP inbox and sent item folders	kenelder	Outlook	1	07-17-2015 02:58 PM