I am trying to automatically truncate a long conversation between two people which has been pasted into word.
Input
Jim , 18th November 05:23
Hi!
Sarah , 19th November 06:03
Hello there
I want to format all text from Jim blue, and all text from Sarah red. In order to do this I think I need to follow this process:
Colour every bit of text red
Find a line starting with "Jim ," and format everything after it blue until it reaches a line which starts with "Sarah ,".
Hope this helps
Public Sub ColorMeRedBlue()
Selection.HomeKey Unit:=wdStory
color_the_text = False
For Each line_in_para In ActiveDocument.Paragraphs
text_in_line = line_in_para.Range.Text
check_name = Split(text_in_line, " ")
If InStr("Jim", check_name(0)) Then
color_the_text = False
ElseIf InStr("Sarah", check_name(0)) Then
color_the_text = True
End If
If color_the_text = False Then
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Color = wdColorRed
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1
ElseIf color_the_text = True Then
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Color = wdColorBlue
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1
End If
Next line_in_para
End Sub
Related
I have two books of the same title: one English, one Spanish. I want to combine them so I can learn Spanish. So I need a single Word document that has one paragraph in English, followed by the same paragraph in Spanish, over and over again. Below is what I have from manually copy/pasting, but I would like to automate it using a patter of (a) copy/pasting by paragraph break, or (b) copy/pasting every 350 characters (or 100 words) with a punctuation being the end point. This is what I have so far:
Sub Macro1()
Windows("3.doc - Compatibility Mode").Activate
Selection.MoveDown Unit:=wdLine, Count:=13, Extend:=wdExtend
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.Copy
Windows("Document2").Activate
Windows("656398.docx - Compatibility Mode").Activate
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.MoveDown Unit:=wdLine, Count:=23, Extend:=wdExtend
Selection.MoveUp Unit:=wdLine, Count:=7, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.Copy
Windows("Document2").Activate
Windows("3.doc - Compatibility Mode").Activate
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveDown Unit:=wdLine, Count:=8, Extend:=wdExtend
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Copy
Windows("Document2").Activate
Windows("656398.docx - Compatibility Mode").Activate
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.MoveDown Unit:=wdLine, Count:=18, Extend:=wdExtend
Selection.Copy
Windows("Document2").Activate
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeParagraph
Selection.TypeParagraph
Selection.PasteAndFormat (wdUseDestinationStylesRecovery)
ActiveDocument.Save
End Sub
For example, provided the documents have exactly the same paragraphing:
Sub AddSecondLanguage()
Application.ScreenUpdating = False
Dim DocA As Document, DocB As Document, Rng As Range, i As Long
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
.Title = "Select the source document containing the primary language."
.InitialFileName = "C:\Users\" & Environ("Username") & "\Documents\"
.AllowMultiSelect = False
If .Show = -1 Then
Set DocA = Documents.Open(.SelectedItems(1), ReadOnly:=True, AddToRecentFiles:=False)
Else
MsgBox "No primary language file selected. Exiting.", vbExclamation: Exit Sub
End If
End With
With Application.FileDialog(FileDialogType:=msoFileDialogFilePicker)
.Title = "Select the source document containing the secondary language."
.InitialFileName = DocA.Path & "\"
.AllowMultiSelect = False
If .Show = -1 Then
Set DocB = Documents.Open(.SelectedItems(1), ReadOnly:=False, AddToRecentFiles:=True)
Else
MsgBox "No secondary language file selected. Exiting.", vbExclamation
DocA.Close SaveChanges:=False: Set DocA = Nothing: Exit Sub
End If
End With
With DocB
For i = .Paragraphs.Count To 1 Step -1
Set Rng = .Paragraphs(i).Range
Rng.Collapse wdCollapseStart
Rng.FormattedText = DocA.Paragraphs(i).Range.FormattedText
Next
.SaveAs2 FileName:=Split(DocA.FullName, ".doc")(0) & "-Combined.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
End With
DocA.Close SaveChanges:=False
Set DocA = Nothing: Set DocB = Nothing
Application.ScreenUpdating = True
End Sub
The combined document will be saved in the docx format with the same name as the first document you open, with '-Combined' added to the filename.
I've tried to select first three rows after for each of page. It works fine only for first page. After first page I am finding manual page break ("^m") and try to select first three rows, but I got only two. Also this macros was written for Word 2007 and I try to rewrite to Word 2016
Do While .Execute(FindText:="^m") = True
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.HomeKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Selection.Range.Case = wdLowerCase
Selection.Range.Case = wdTitleWord
headNumber = "2"
lunghezza = 0
cap = Selection.Text
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.TypeText Text:=headNumber
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Text <> vbCr Then
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1, Extend:=wdExtend
End If
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Style = ActiveDocument.Styles("Custom Style " + NameOfStyle)
It's not a problem to select the first three lines of a document. I would probably use Selection.GoTo for that instead of trying to find manual breaks. I'm not clear what you want to do with the selection, so I'm going to put this stub of an answer in to show the page and line selection until I get some clarity on that. I tested this with about 10 pages of random text using both natural and manual page breaks, with some cases of multiple consecutive manual page breaks.
Sub test()
Dim p As Integer
For p = 1 To ActiveDocument.ActiveWindow.Panes(1).Pages.Count
Selection.GoTo wdGoToPage, wdGoToAbsolute, p
Selection.MoveDown Unit:=wdLine, Count:=3, Extend:=wdExtend
Next
End Sub
When I run the my VBA code on the following text, it works fine till it gets to the paragraph break. I try to run a test for paragraph breaks but it comes up as FALSE:
OK, so that now we're recording.
Uhm, so I spoke with Berry,
which actually your own berries
team now, right?
The output looks like this:
OK, so that now we're recording. Uhm, so I spoke with Berry, which actually your own berries team now, right
Here is my original code:
Sub OneLine()
Dim charCount As Integer
'Go to End of document and add "
Selection.EndKey Unit:=wdStory
Selection.TypeText Text:=" """
'Go to beginning of Document
Selection.GoTo what:=wdGoToSection, Which:=wdGoToFirst
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Count how many characters are in Selection
charCount = Len(Selection)
Set myRange = Selection
myRange.Find.Execute FindText:="""", Forward:=True
'MsgBox (myRange.Find.found)
Do While myRange.Find.found = False
If charCount > 1 Then
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.TypeBackspace
Selection.TypeText Text:=" "
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
charCount = Len(Selection)
Else
Selection.Delete
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
charCount = Len(Selection)
End If
Set myRange = Selection
myRange.Find.Execute FindText:="""", Forward:=True
'MsgBox (myRange.Find.found)
Loop
Selection.TypeBackspace
Selection.TypeBackspace
Selection.TypeBackspace
Selection.GoTo what:=wdGoToSection, Which:=wdGoToFirst
End Sub
I tried using Find.Text:= "^p" statement with an IF THEN but it came out as FALSE.
Thank you in advanced!
Figured it out.
i used the following lines:
With Selection.Find
.Execute FindText:=vbCrLf
.Forward = True
End With
Originally I was only looking for one thing, paragraph break or line break but not the combo of line feed and carriage return: vbCRLf. I was also using "vbCrLf" which is wrong because at that point it's looking for that string.
This is my final code:
Sub OneLine()
Dim charCount As Integer
'Go to End of document and add "
Selection.EndKey Unit:=wdStory
Selection.TypeText Text:=" """
'Go to beginning of Document
Selection.GoTo what:=wdGoToSection, Which:=wdGoToFirst
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
'Count how many characters are in Selection
charCount = Len(Selection)
Set myRange = Selection
myRange.Find.Execute FindText:=""""
'MsgBox (myRange.Find.found)
Do While myRange.Find.found = False
If charCount > 1 Then
With Selection.Find
.Execute FindText:=vbCrLf
.Forward = True
End With
If ((Selection.Find.found = True) And (charCount = 2)) Then
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.TypeBackspace
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
charCount = Len(Selection)
Else
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdMove
Selection.HomeKey Unit:=wdLine, Extend:=wdMove
Selection.TypeBackspace
Selection.TypeText Text:=" "
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
charCount = Len(Selection)
End If
Else
Selection.Delete
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
charCount = Len(Selection)
End If
Set myRange = Selection
myRange.Find.Execute FindText:=""""
'MsgBox (myRange.Find.found)
Loop
Selection.TypeBackspace
Selection.TypeBackspace
Selection.TypeBackspace
Selection.GoTo what:=wdGoToSection, Which:=wdGoToFirst
End Sub
I have a table in MS Word that is 2 columns by 1,000 rows. I made a macro that, in order,
adds a new row below the current one,
merges the two cells in the new row,
cuts and pastes the text from an above cell into the new row,
moves an image over one column, and
adds text to a cell. Once it completes that string of events the cursor is in position to do it all again.
There are no conditions that can screw it up as it runs (i.e. empty cells, etc), I do not need the code to to look for specific things, I just need it to repeat.
What do I need to add to this existing code to have this repeat until the end of the document (specifically 1,000 times).
I have seen code for Excel, but I have not seen code for going through a table in Word.
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
Selection.InsertRowsBelow 1
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
Selection.Cells.Merge
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.Font.Size = 4
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Size = 3
Selection.TypeText Text:="Unique specimen identifier not a property tag"
Selection.MoveDown Unit:=wdLine, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1
All I expect is to be able to run the code once and have it repeat until it hits the end of the document, and if possible to repeat specifically 1,000 times.
I hope this is not too "broad" since I have the code and am asking a specific question.
You can repeat your set of instructions by wrapping it into a For...Next loop, which is fairly standard across VBA applications. This code creates a loop and an 'index' variable, and then tells it to step through that index exactly 1000 times.
For index As Integer = 1 To 1000
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
Selection.InsertRowsBelow 1
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=2, Extend:=wdExtend
Selection.Cells.Merge
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.Font.Size = 4
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.Cut
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.PasteAndFormat (wdPasteDefault)
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Font.Size = 3
Selection.TypeText Text:="Unique specimen identifier not a property tag"
Selection.MoveDown Unit:=wdLine, Count:=2
Selection.MoveLeft Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Next
If you ever need to loop something an indeterminate amount of times, for example when a specific criterion is met, you would use a Do...While or Do...Until loop, instead.
My title didn't seem to match questions that may have my answer, and I did find some snippets from other threads/sites to help me get this far. I'm looking for assistance tying the entire macro together. Here is what I have so far:
Sub Test()
Selection.EndKey Unit:=wdStory
Dim oPara1 As Word.Paragraph
Set oDoc = oWord.Documents.Add
Set oPara1 = oDoc.Content.Paragraphs.Add
With oPara1.Range
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.InsertParagraphAfter
With .Font
.Name = "Times New Roman"
.Size = "12"
.Bold = True
End With
End With
Selection.TypeText Text:="Fosters, Inc."
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.TypeText Text:="www.genericwebsite.com"
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
'this needs to be left alignment from here on out
Selection.TypeText Text:="Block\Paragraph Format:"
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.TypeText Text:="Run Date:"
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.TypeText Text:="Picture:"
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.TypeText Text:="Symbol:"
Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend
Selection.TypeText Text:="Guest Book:"
End Sub
I want it to move to the end of the document and print:
Fosters, Inc.
www.genericwebsite.com
Block\Paragraph Format:
Run Date:
Picture:
Symbol:
Guest Book:
Thanks for any help - I've spent literally just an hour or so with vba in Word today.
Option Explicit
Sub Test()
Selection.EndKey Unit:=wdStory
Dim oPara1 As Word.Paragraph
Dim oDoc As Word.Document
Set oDoc = ActiveDocument
Set oPara1 = oDoc.Content.Paragraphs.Add
With oPara1.Range
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.InsertParagraphAfter
With .Font
.Name = "Times New Roman"
.Size = "12"
.Bold = True
End With
End With
Selection.TypeText Text:=vbCr
Selection.TypeText Text:="Fosters, Inc." & vbCr
Selection.TypeText Text:="www.genericwebsite.com" & vbCr
oPara1.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
Selection.TypeText Text:="Block\Paragraph Format:" & vbCr
Selection.TypeText Text:="Run Date:" & vbCr
Selection.TypeText Text:="Picture:" & vbCr
Selection.TypeText Text:="Symbol:" & vbCr
Selection.TypeText Text:="Guest Book:"
End Sub