I am currently copying a lot of diagrams from excel to word via macro. I used the Record Macro functionality which helped me to produce the following code:
Set charts = Sheets("Charts").ChartObjects
For Each chart In charts
WordApplication.Selection.TypeParagraph
WordApplication.ActiveDocument.Tables.Add Range:=WordApplication.Selection.Range, NumRows:=2, NumColumns:= _
1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With WordApplication.Selection.Tables(1)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
WordApplication.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
chart.Copy
WordApplication.Selection.Paste
WordApplication.Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
' configure the shape (resizing)
WordApplication.Selection.MoveDown Unit:=wdLine, Count:=2
Next
So what I do is, put a Return, add a table with 2 rows and align the first row to Center. Then add the chart by copying it from Excel and pasting it into Word. Do some tinkering with the shape (removed) by selecting it (via the MoveLeft command) and finally, move 2 steps down (to leave the table) and redo for all the charts.
If I step through this with F8 I get the result I want. However, if I just let it run I see different result all the time, for instance:
The selection stays in the table even after the MoveDown command
The shape is still selected after the MoveDown command
run-time error '4605': This method or property is not available because the object refers to the end of a table row (due to the selection not being moved and the Tables.Add is done inside the previous table
correct result
My question:
How can I make it work without having to step through the macro manually?
Using Windows XP, Excel 2007 (12.0.65.62.5003). Note that the issue does not behave the same on Windows 7 (not tested on Windows Vista).
It seems the last line didn't always leave the table that I inserted. I replaced the following line:
WordApplication.Selection.MoveDown Unit:=wdLine, Count:=2
with this
Do Until Not WordApplication.Selection.Information(wdWithInTable)
WordApplication.Selection.MoveRight Unit:=wdCharacter, Count:=1
Loop
And now it works as it should
Related
I have a word file where, which stores information from a SharePoint site into a document. I need to use word (instead of Excel for instance, where conditional formatting would easily fix this problem). There are a few tables in my word document, which gets automatically information from a SharePoint site. However, I would like to get some of the cells background colored if the input value in the cell is "Scheduled" -> Yellow, "Under Work" -> Blue & "Finished" -> Green.
I have Office 2016 O365 in use, which then automatically generates a pdf of the word file after all data is stored, which is then finally sent to different users. I have a working code for the background color change but it always needs to be executed instead of doing this automatically when the cell value changes. Can anyone please help me to rewrite the attached code to work automatically instead of needed to be manually executed every time. I can't find an answer to this problem so hopefully someone here can provide me with a solution.
Sub ColorCells()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
Select Case oRng.Text
Case "Scheduled"
oCel.Shading.BackgroundPatternColorIndex = wdYellow
Case "Under Work"
oCel.Shading.BackgroundPatternColorIndex = wdTurquoise
Case "Finished"
oCel.Shading.BackgroundPatternColorIndex = wdBrightGreen
Case Is <> "Scheduled"
oCel.Shading.BackgroundPatternColorIndex = wdNoHighlight
Case Is <> "Under Work"
oCel.Shading.BackgroundPatternColorIndex = wdNoHighlight
Case Is <> "Finished"
oCel.Shading.BackgroundPatternColorIndex = wdNoHighlight
End Select
Next
Next
End Sub
I expect to get all the cells background colored, with the text "Scheduled", "Under Work" & "Finished" to Yellow, Blue & Green. All the other cells with some other information stored should be without any background color.
I am trying to center the first line of text on a document, which would usually be the title.
I am able to center the line with
Selection.Paragraphs.Alignment = wdAlignParagraphCenter
But I am not sure how it is selecting the file line, as I would also like to set the title to bold and caps.
Selection.Font.Bold = wdToggle
Selection.Font.AllCaps = True
_
Also is there a way to "detect" any text that is centered already and has an empty space(line) above and below it, or would that be too difficult to achieve?
Use a with statement to apply multiple formats. Here is an example:
With Selection
.Paragraphs.Alignment = wdAlignParagraphCenter
.Font.Bold = wdToggle
.Font.AllCaps = True
End With
I have created a userform with a multiselect listbox with an "OK" command. When my user makes selections from the listbox and clicks the OK command, I want to create an array (based on the user's selections in the listbox) that I can then loop over for each item in the array as I open multiple files the user has specified.
For example, if my user selects "Client 1" and "Client 3" in my listbox and then selects the "OK" command, I want to create an array from those values and then call up each value in the array in a "find and replace" Sub that replaces, e.g., "Client 1" with "Client 1" (colored red), "Client 3" with "Client 3" (colored red). (The red is so that my other find and replace macro can skip these items by specifying a different color to find for, along with text Client 1, Client 3, etc.)
Reading elsewhere on this site, I created a function to try to generate the array, but I don't know how to get it into and use it in my UserForm Sub.
After finding an answer, below, I deleted the original code I had pasted here, because it was clearly all wrong and won't help anyone.
Additional information about the overall objective: I have already created a macro to do an initial find and replace in multiple files. This macro opens a bunch of files selected by the user and replaces certain client names with the text "Confidential Client". Now, people are asking me if they can exclude certain clients from being replaced. That is why I want to add the userform with a listbox that will let them select clients to exclude.
Please help!
So, through much trial and error and googling, I came up with the following solution, which works well for my purpose. First, after clicking F7 on my userform, I added the items to a list array.
Private Sub UserForm_Initialize()
'Creates and assigns the array to ListBoxClients when the form loads
With ListBoxClients
.AddItem "Client 1"
.AddItem "Client 2"
.AddItem "Client 3"
End With
End Sub
Then, I created the following response to my "OK" command. First, it prompts the user to select the files to process and opens the first file:
Private Sub cmdOK_Click()
Me.Hide
MsgBox "Click OK to browse and select files to exclude.", vbInformation
Dim MyDialog As FileDialog, GetStr(1 To 3000) As String '3000 files is the maximum applying this code
On Error Resume Next
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
For j = 1 To i Step 1
Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Then, I loop through the selected items in the array and replace each selected item with the same text, colored red (so my other macro--not shown here--will skip over it when it performs the find and replace):
'Find and replace listbox items in files
Dim ii As Integer
For ii = 0 To ListBoxClients.ListCount - 1
If ListBoxClients.Selected(ii) Then
Selection.Text = ListBoxClients.List(ii)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Color = 192
With Selection.Find
.Text = Selection.Text
.Replacement.Text = Selection.Text
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Before I finish, I get rid of the selected array item that for reasons unknown is pasted at the top of each of my files:
' delete mysterious added text at top of page (figure this out later)
Selection.HomeKey Unit:=wdStory
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
End If
Next ii
Then I have some code that closes the current document and returns it to the top section of the sub to open the next file (and eventually end). I have no idea why "Application.Run macroname:="NEWMACROS" is there, but it works, so I'm not going to delete it.
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
End Sub
Finally, I add the code to cancel the form if the user changes his/her mind:
Private Sub cmdCancel_Click()
'User has cancelled so hide the form
Me.Hide
End Sub
That's it. I hope this helps someone else.
I would like to alter a Word document by using a Word VBA script. The Word document consists of bibliographic records. I would like to duplicate the first occurrence of field \TRF of each record and to change its field label (into \OTT). I recorded a VBA Script and it works fine if I position the cursor in front of the first occurrence of \TRF. I would like the VBA Script to repeat the alterations in the entire document but to only alter all first occurrences of \TRF. Recording a VBA Script with keyboard keys (Ctrl+F) plus text didn’t work. And my attempts to add vba code to the VBA Script where not successful.. What is the correct syntax I have to add to my VBA Script?
Original text:
(this example displays one record, the document contains more records)
\PPN 375496173
\TTT Pour un autre regard sur l'art beti / Bienvenu Cyrille Bela
\TRF Cameroon
\TRF Beti
\TRF sculpture
\TRF visual arts
\DAT 15-08-14
\DAV 20140815
\SIG AFRIKA 47231
\ISP text
\END
Text after alteration
\PPN 375496173
\TTT Pour un autre regard sur l'art beti / Bienvenu Cyrille Bela
\TRF Cameroon
\OTT Cameroon
\TRF Beti
\TRF sculpture
\TRF visual arts
\DAT 15-08-14
\DAV 20140815
\SIG AFRIKA 47231
\ISP text
\END
Incorrect macro:
Sub MacroCountry()
' MacroCountry Macro
With ActiveDocument.Content.Find
'Search for \PPN (beginning of the record) and then search for \TRF
.Text = "\PPN"
.Text = "\TRF"
'the selection part of the Macro works fine, it selects the line, duplicates it and changes the field label
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Copy
Selection.MoveRight Unit:=wdWord, Count:=1
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdWord, Count:=2, Extend:=wdExtend
Selection.TypeText Text:="\Ott "
End With
Loop
End Sub
I'm trying to find out a little bit more about MS Word framework so I used this as exercise. You could try this. Precondition is that all lines are ending with newlines so each line is a paragraph.
Sub InsertLines()
Dim rng As Range
Dim i As Integer
Dim doc As Document
Dim line As String
Dim inBlock As Boolean, found As Boolean
Set doc = ThisDocument
i = 1
While i < ThisDocument.Paragraphs.Count
line = doc.Paragraphs(i).Range.Text
If InStr(line, "\PPN") > 0 Then
inBlock = True
found = False
End If
If InStr(line, "\END") > 0 Then
inBlock = False
End If
If inBlock And Not found Then
If InStr(line, "\TRF") > 0 Then
doc.Paragraphs(i).Range.InsertAfter "\OTT " & Mid(line, 5)
found = True
End If
End If
i = i + 1
Wend
End Sub
I'm sure there are more elegant solutions but I hope this is a solution at all. I tried a little bit with RegExp and Find object but this is more straightforward.
I would like to delete certain lines from my word document using a VBA macro. Basically the (block of) text to be deleted (and replaced by "***") follows a certain pattern (below).
Bottom of Form
perma-link
Top of Form
save
Bottom of Form
[+] ....
[–] ....
Top of Form
"...." represents text that changes every block, but for sure the line starts with "[+]" or "[-]".
Please suggest a suitable macro
EDIT: In the screenshot, I would like to keep the text in yellow and delete the rest. (in the actual file, the text isn't in yellow)
PS-FYI, I tried using the example looping a find and delete row macro (for line by line deletion) but i get a runtime error 5941 with debugging option highlighting the line "selection.row.delete" in the macro.
What does this mean?
Assuming that the example list is a list of paragraphs beginnings the following code should do the trick. What you have to do is to place all 'paragraphs starting' into array arrRemove as I did for the test. If any of the mark is a special marks (see this link for additional information) you need to add \ in front of it as I did for [+] and [-]. Hope this is what you are looking for.
Sub Macro2()
Dim arrRemove As Variant
arrRemove = Array("Bottom of Form", "perma -link", "Top of Form", _
"\[+\]", "\[\-\]", "Donec", "In")
Dim i!
For i = 0 To UBound(arrRemove)
Activedocument.Range(0,0).select
Selection.Find.ClearFormatting
With Selection.Find
.Text = arrRemove(i) & "*^13"
.Replacement.Text = "" 'replace with nothing
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next i
End Sub
The above macro will remove all yellow paragraph in the following document.