#1
|
|||
|
|||
Delete table lines/Condense table
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 I have attached a sample: sampletext.docx |
#2
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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 |
#4
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Tags |
macro, tables, vba |
|
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 |