CODEWITHSUNDEEP
excelvba
uttuck
uttuck

Reputation: 51

Combine text in cells vertically

Someone created a text document in Excel like it was on a typewriter. They wrote to the end of the screen then hit enter.

I'd like to put each paragraph into it's own cell then copy and paste to Word.

I tried recording a macro, but it get stuck between paragraphs (author skipped a line between paragraphs). My research shows concatenating cells one at a time, which won't help me with about 1000 lines of text.

The VBA would be something like:

' If cell below isn't empty
' then
' activecell=activecell&activecell(0,1)
' delete activecell(0,1)
' else activecell(0,2).select
'endif
'loop 1000 times

If the current document says:

A boy walked down
the street.

Next he tried
to run.

Finally this task
was over.

After it would look like:

A boy walked down the street.

Next he tried to run.

Finally this task was over.

Upvotes: 0

Views: 229

Answers (3)

dnacarlos
dnacarlos

Reputation: 91

Additional option, text can be copied from the immediate window after running the macro. You can access this through View or Ctrl+ G in the VBA developer window.

Sub Concatenate_Text()
Dim i As Long
Dim lastrow As Long
Dim paragraph As String

Dim wb As Workbook
Dim ws As Worksheet

Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")

lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

For i = 1 To lastrow
    If IsEmpty(ws.Cells(i, "A")) = False Then
    paragraph = paragraph & " " & ws.Cells(i, "A").Value & " " & ws.Cells(i + 1, "A").Value
    i = i + 1
    Else: paragraph = paragraph & vbCrLf
    End If

Next i

Debug.Print paragraph

End Sub

Upvotes: 0

Nathan Sutherland
Nathan Sutherland

Reputation: 1270

Another option

Sub compileDoc()
    Dim textArr(), r As Long, n As Long, curPar As String

    textArr = Sheet1.Range("A2:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Value
    n = LBound(textArr)
    For r = LBound(textArr) To UBound(textArr)
        If Len(textArr(r, 1)) Then
            curPar = curPar & " " & textArr(r, 1)
            textArr(r, 1) = ""
        Else
            textArr(n, 1) = WorksheetFunction.Trim(curPar)
            n = n + 1
            curPar = ""
        End If
    Next r
    textArr(n, 1) = curPar
    Sheet1.Range("B2:B" & n + 1) = textArr
End Sub

Upvotes: 0

cybernetic.nomad
cybernetic.nomad

Reputation: 6418

Assuming my assumptions are correct, try the following:

  1. Copy everything to Word.

  2. Do a Find/Replace for two carriage returns (^p^p) and replace them with a placeholder string (ex.: %%%%%, anything will do as long as it is not in your document)

  3. Do a Find/Replace for single carriage returns (^p) and replace them with a single space ()

  4. Do a Find/Replace for your placeholder string (%%%%% in my example above) and replace it with two carriage returns (^p^p)

  5. You may need to do a Find/Replace on double-spaces and replace them with single spaces.

After proofing and perhaps some tweaking, you should be done.

Upvotes: 3

Related Questions