Delete table lines/Condense table

frustrated teacher · #1 12-13-2015, 01:47 PM

Hello friends,

It's another year of exams for my students and I am stuck trying to upload an exam to our antiquated system.

The exam system takes a particular format, I figured out how to upload the questions, but not the answers.

The questions are in tables.

1. This animal says meow.
a. cat
b. dog
c. mouse
d. bird

ANS: A

2. This animal says woof.
a. cat
b. dog
c. mouse
d. bird

ANS: B

3. Birds have wings.

ANS: T

Ideally, I would like it to look like:

This animal says meow. a. cat

This animal says woof. b. dog

Birds have wings. T

I had a similar macro that I was taught last year on this forum:

Code:

Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchWildcards = True
    .Text = "([0-9]@\)*^13)(*)(Answer:*^13)"
    .Replacement.Text = "\1\3\2"
    .Execute Replace:=wdReplaceAll
    .Text = "^13^13"
    .Replacement.Text = "^px^&"
    .Execute Replace:=wdReplaceAll
    .Text = "[0-9]@\) (*Answer:*)([A-Z])*(\2\)*^13)*^13{2}"
    .Replacement.Text = "\1\3^p"
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

However, that deals with a different initial format.
I have attached a sample:
sampletext.docx

macropod · #2 12-13-2015, 09:20 PM

Try:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim strAns As String
With ActiveDocument.Range
  While .Tables.Count > 0
    .Tables(1).ConvertToText
  Wend
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .MatchWildcards = True
    .Wrap = wdFindContinue
    .Text = "([0-9]{1,}.^t*^13)(*)(ANS:^t*)^t*^13"
    .Replacement.Text = "\1\3^p\2"
    .Execute Replace:=wdReplaceAll
    .Wrap = wdFindStop
    .Text = "(ANS:*)^13"
    .Replacement.Text = "\1"
    .Execute
  End With
  Do While .Find.Found
    strAns = LCase(.Characters.Last.Previous)
    .Text = "ANS: " & .Characters.Last.Previous & vbCr
    Do While Len(Trim(.Paragraphs.Last.Next.Range.Text)) > 1
      If .Paragraphs.Last.Next.Range.Characters.First <> strAns Then
        .Paragraphs.Last.Next.Range.Delete
      Else
        .Paragraphs.Last.Next.Range.Characters.First.Delete
        .Start = .Paragraphs.Last.Range.End
      End If
    Loop
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  With .Find
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

frustrated teacher · #3 12-13-2015, 09:56 PM

Thank you that was wonderful.

Is it possible to have no leading numbers and to have everything on one line?

The format I get now is this:

1. What color is the sky?
ANS: A.-blue
2. A cow says:
ANS: C.-moo
3. The sun is shaped like:
ANS: A.-a circle
4. Birds have wings.
ANS: T
5. Elephants are small.
ANS: F

How do I go from that to:

This animal says meow. ANS: a. cat

This animal says woof. ANS: b. dog

Birds have wings. ANS: T

macropod · #4 12-14-2015, 02:03 AM

Try:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim strAns As String
With ActiveDocument.Range
  While .Tables.Count > 0
    .Tables(1).ConvertToText
  Wend
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Format = False
    .Forward = True
    .MatchWildcards = True
    .Wrap = wdFindContinue
    .Text = "([0-9]{1,}.^t*^13)(*)(ANS:^t*)^t*^13"
    .Replacement.Text = "\1\3^p\2"
    .Execute Replace:=wdReplaceAll
    .Wrap = wdFindStop
    .Text = "(ANS:*)^13"
    .Replacement.Text = "\1"
    .Execute
  End With
  Do While .Find.Found
    If Asc(.Characters.Last.Previous) < 70 Then
      strAns = LCase(.Characters.Last.Previous)
    Else
      strAns = .Characters.Last.Previous
    End If
    .Text = "ANS: " & strAns & vbCr
    Do While Len(Trim(.Paragraphs.Last.Next.Range.Text)) > 1
      If .Paragraphs.Last.Next.Range.Characters.First <> strAns Then
        .Paragraphs.Last.Next.Range.Delete
      Else
        .Paragraphs.Last.Next.Range.Characters.First.Delete
        .Start = .Paragraphs.Last.Range.End
      End If
    Loop
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
  .Start = ActiveDocument.Range.Start
  With .Find
    .Wrap = wdFindContinue
    .Execute Replace:=wdReplaceAll
    .Text = "^13(ANS:*)^13"
    .Replacement.Text = " \1"
    .Execute Replace:=wdReplaceAll
    .Text = "^13^t"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
  End With
End With
Application.ScreenUpdating = True
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Copying multiple lines in a table	Surge	Word	3	09-19-2015 04:01 AM
How can I delete spaces & lines in a table cell	mrayncrental	Word VBA	3	10-20-2014 07:09 PM
How do I make invisible the lines in the table	Snvlsfoal	Word Tables	1	08-11-2011 05:45 AM
table composed from lines (drawing)	czomberzdaniela	Word Tables	8	04-12-2011 05:48 AM
Adding table lines to protected form	razberri	Word Tables	2	10-27-2010 05:58 PM