Insert a row above a selected row in a table - vba

I know, I have seen this link: Word 2016- VBA- How To Insert Row Below Selected Row In A Table?
But, unfortunately, even if it may be trivial, I don't understand how to do it.
Here is what I want to do: 1)to add row(s) (from docSource) at the end of a Table (first part working well) OR 2)to add row(s) (from docSource) above the selected row (row selected on docTarget) (second part struggling to find the right way).
Dim docTarget As Document
Dim docSource As Document
Set docTarget = ActiveDocument
Set docSource = Documents.Open(strFileName)
IF SOMETHING THEN
'1) Working code
Dim myRange As Object
Set myRange = docTarget.Content
myRange.Collapse Direction:=wdCollapseEnd
myRange.FormattedText = docSource.Tables(2).Range.FormattedText
ELSE
'2) Can't figure it out
Dim myRange2 As Object
Set myRange2 = docTarget.Content
myRange2.Select 'What? - the row I already highlighted -
Selection.InsertRowsBelow
myRange2.FormattedText = docSource.Tables(2).Range.FormattedText
ENDIF
docSource.Close (0)
Set docSource = Nothing
Set docTarget = Nothing
For information, my tables from docSource or docTarget got 3 columns and no merge cells.
I welcome any ideas or tips.
Thanks.

I think I found the answer, thanks to the patience of Timothy Rylatt. But if you have any positive critics or improvements (better coding), please do not hesitate to comment.
First, before opening my userform, I got this:
mySelectedRow = Selection.Information(wdEndOfRangeRowNumber)
mySlectedRow declare as Public
Second, in the userform, I got this:
Private Sub btnOK_Click()
Dim strFileName As String
strFileName = ActiveDocument.Path & "\something\" & cboFileOption.Text
' Open selected item as docSource and assign docTarget to this document
Dim docTarget As Document
Dim docSource As Document
Set docTarget = ActiveDocument
Set docSource = Documents.Open(strFileName)
' Fill docTarget with the content of docSource
Dim myRange As Object
Set myRange = docTarget.Content
If Me.optEndTable.Value = True Then
myRange.Collapse Direction:=wdCollapseEnd
myRange.FormattedText = docSource.Tables(2).Range.FormattedText
Else
docSource.Tables(2).Range.FormattedText.Copy
docTarget.Content.Tables(1).Rows(mySelectedRow).Select
Selection.Rows(Selection.Rows.Count).Range.Paste
End If
' Close selected item (docSource) without saving
docSource.Close (0)
Set docSource = Nothing
Set docTarget = Nothing
' End
Me.Hide
End Sub
Hope that make sense.
Thanks

Related

Hide full row if cells are merged in word table

I have a file with multiple tables and by using the below code I am trying to access the rows which have specific terms using an array.
I successfully select the whole rows and apply hidden formatting on it but it selects only the first rows of the merged cell, not the whole row.
Below is the result that I am getting.
But I am seeking a result that will hide all content in 4 columns but I am unable to find a solution for the same.
Sub test()
Dim SearchArr() As Variant, Cnt As Integer, Arrcnt As Integer
Dim WrdApp As Object, FileStr As String, WrdDoc As Object, aRng As Range
Dim TblCell As Variant
Set WrdApp = CreateObject("Word.Application")
WrdApp.Visible = True
'********** change address to suit
FileStr = "C:\Users\krishna.haldunde\Downloads\New folder\Episode_0_intro_UEFA_v1_EN.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("Slide Notes")
'loop tables
For Cnt = 1 To WrdApp.ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each TblCell In WrdApp.ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = TblCell.Range
'If TblCell.RowIndex = WrdApp.ActiveDocument.Tables(Cnt).Rows.Count Then Exit For
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
aRng.Rows.Select
WrdApp.Selection.Font.Hidden = True
WrdApp.Selection.Range.HighlightColorIndex = wdBlue
'WrdApp.Selection.Range.Next.Rows.Select
'WrdApp.Selection.Font.Hidden = True
'WrdApp.Selection.Range.HighlightColorIndex = wdBlue
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where I am doing the issue so, I can rectify it?

How can I convert all tables in a word document to images?

Below is my attempt but it's producing odd results, and the results seem to change each time i run the macro...
Can anyone see any issues in my code or can think of a better way of doing this?
Sub ConvertTablesToImages()
Dim tbl As Table
Dim currentDoc As Document
Set currentDoc = ActiveDocument
For Each tbl In currentDoc.Tables
tbl.Range.Copy
Selection.Collapse Direction:=wdCollapseStart
Selection.PasteSpecial DataType:=wdPasteEnhancedMetafile
tbl.Delete
Next
End Sub
You had a few problems. One is mixing ranges and selections and the other is deleting members of a collection (in this case tables in the document) while trying to loop through all of them.
Take a look at this revision of your code. It should work better.
Sub ConvertTablesToImages()
Dim tbl As Table, rng As Range, i As Integer
Dim currentDoc As Document
Set currentDoc = ActiveDocument
For i = currentDoc.Tables.Count To 1 Step -1
Set tbl = currentDoc.Tables(i)
Set rng = tbl.Range
rng.Collapse Direction:=wdCollapseStart
tbl.Range.CopyAsPicture
tbl.Delete
rng.PasteSpecial DataType:=wdPasteEnhancedMetafile
rng.ShapeRange(1).ConvertToInlineShape
Next
End Sub
Just adding a variation to Rich's answer for anyone who finds that their tables are being cropped in some of the pasted images.
Adding tbl.PreferredWidth = 0 seemed to fix this
Sub ConvertTablesToImages()
Dim tbl As Table, rng As Range, i As Integer
Dim currentDoc As Document
Set currentDoc = ActiveDocument
For i = currentDoc.Tables.Count To 1 Step -1
Set tbl = currentDoc.Tables(i)
Set rng = tbl.Range
tbl.PreferredWidth = 0
rng.Collapse Direction:=wdCollapseStart
tbl.Range.CopyAsPicture
tbl.Delete
rng.PasteSpecial DataType:=wdPasteEnhancedMetafile
rng.ShapeRange(1).ConvertToInlineShape
Next
End Sub

Transferring data from excel to MS word

I need a VBA code to update my word file. It which consists of some tables That has to be updated from excel file. Excel file consists of bearing data with different bearing numbers. And my report has to be updated with the bearing values. Like for my next report if I just enter the different bearing file it must read all the bearing data from that file.
This has to be done in 3 steps. I have attached a sample image. firstly identify the bearing name which is always in A column (In this case I need to find (248_R), 38,7 % ). Then select 6*6 matrix data (suppose I find the bearing data to be in A946 then I need to record data from B950 to G955) and then transfer to word file(Only the values to the table). I am a newbee in VBA coding please can someone help?
image of sample bearing name with matrix underneath
Image of what the tables look like in the word document:
The first part of copying the range you want is relatively easy. You can use the following code to copy your desired matrix. I am not sure about pasting to a word document yet, give me some more time on that.
(For now, if you run this macro, the range you want will be copied. You can then switch to your word document and hit Ctrl+V to paste it into the desired table.
Also, please check and see whether the following references have been added:
Option Explicit
Sub findBearingDataAndPasteToWord()
Dim i As Integer
Dim aCell As Range, rng As Range
Dim SearchString As String
Set rng = Range("A750:A1790")
SearchString = "(248_R), 38,7 %"
For Each aCell In rng
If InStr(1, aCell.Value, SearchString, vbTextCompare) Then
ActiveSheet.Range(Cells(aCell.row + 4, 1), Cells(aCell.row + 9, 6)).Copy
Dim wrdApp As Word.Application
Dim docWd As Word.Document
MsgBox "Please select the word document that you want to paste the copied table data into (after pressing OK)" & _
vbNewLine & vbNewLine & "Script written by takanuva15 with help from Stack Overflow"
docFilename = Application.GetOpenFilename()
If docFilename = "False" Then Exit Sub
Set docWd = getDocument(docFilename)
Set wrdApp = docWd.Application
wrdApp.Selection.EndKey Unit:=wdStory
wrdApp.Selection.TypeParagraph
wrdApp.Selection.TypeParagraph
wrdApp.Selection.PasteExcelTable False, True, False
Exit Sub
Else: End If
Next aCell
End Sub
'Returns the document with the given filename
'If the document is already open, then it returns that document
Public Function getDocument(ByVal fullName As String) As Word.Document
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If wrdApp Is Nothing Then Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Dim fileName As String
Dim docReturn As Word.Document
fileName = Dir(fullName)
Set docReturn = Word.Documents(fileName)
If docReturn Is Nothing Then
Set docReturn = Word.Documents.Open(fullName)
End If
On Error GoTo 0
Set getDocument = docReturn
End Function

Use Word VBA to color cells in tables based on cell value

In Word I have a document with multiple tables full of data. Hidden inside these cells (out of view but the data is there) is the Hex code of the color I want to shade the cells. I chose the hex value just because it's relatively short and it's a unique bit of text that won't be confused with the rest of the text in the cell.
I've found some code online to modify but I can't seem to make it work. It doesn't give any errors, just nothing happens. I feel like the problem is in searching the tables for the text value but I've spent hours on this and I think I've confused myself now!
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
If oRng = "CCFFCC" Then
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
End If
If oRng = "FFFF99" Then
oCel.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
Next
Next
End Sub
Thanks!
Edit:
I've also tried this code wit the same result of nothing happening:
Sub EachCellText()
Dim oCell As Word.Cell
Dim strCellString As String
For Each oCell In ActiveDocument.Tables(1).Range.Cells
strCellString = Left(oCell.Range.Text, _
Len(oCell.Range.Text) - 1)
If strCellString = "CCFFFF" Then
oCell.Shading.BackgroundPatternColor = wdColorLightGreen
If strCellString = "CCFFCC" Then
oCell.Shading.BackgroundPatternColor = wdColorLightYellow
If strCellString = "FFFF99" Then
oCell.Shading.BackgroundPatternColor = wdColorPaleBlue
End If
End If
End If
Next
End Sub
Your Code is getting stuck nowhere. But you are checking the whole Cell Value against the Hex code, and this will not work since "blablabla FFFFFF" is never equal to "FFFFFF". So you have to check if the Hex code is in the Cell value:
Sub ColourIn()
Dim oTbl As Table
Dim oCel As Cell
Dim oRng As Range
Dim oClr As String
For Each oTbl In ActiveDocument.Tables
For Each oCel In oTbl.Range.Cells
Set oRng = oCel.Range
oRng.End = oRng.End - 1
Dim cellvalue As String
'check if Colorcode is in cell
If InStr(oRng, "CCFFCC") Then
'Set Cell color
oCel.Shading.BackgroundPatternColor = wdColorLightYellow
'Remove Colorcode from Cell
cellvalue = Replace(oRng, "CCFFCC", "")
'load new value into cell
oRng = cellvalue
End If
Next
Next
End Sub
Now you just have to add all the colors you want to use (I would prefer a Select Case statement) and the code should work fine

How can I update MS Word fields based on contents of other fields within the document?

I am trying to find a way to lookup and replace contents within an MS Word Doc based on certain content within the same document. I have system generated Word Documents that are one page each in length, but the number of pages can vary from one to 100 (or more). Each document is formatted exactly the same. One phrase with each page of the document (such as "Type of Charge" may or may not vary from one page to the next. I need to be able to insert the actual amount of the charge on each page based on the type of charge reflected on that given page.
I was taking the approach of setting bookmark ranges that would be used to search for the phrase, and then setting a bookmark that would indicate where to insert the value. Here is what I have so far:
Sub bmAmtDue()
'
' bmAmtDue
'
'
Dim rng As Range
Dim iBookmarkSuffix As Integer
Dim strBookMarkPrefix
strBookMarkPrefix = "BM"
Set rng = ActiveDocument.Range
With rng.Find
.Text = "Please see fee chart, with additional requirements, on reverse side"
Do While .Execute
rng.Text = "" 'clear the "XXX" (optional)
iBookmarkSuffix = iBookmarkSuffix + 1
ActiveDocument.Bookmarks.Add strBookMarkPrefix & iBookmarkSuffix, rng
Loop
End With
End Sub
Sub bmStartPermitType()
'
' bmStartPermitType
'
'
Dim rng2 As Range
Dim iBookmarkSuffix As Integer
Dim strBookMarkPrefix
strBookMarkPrefix = "BMStartPermitType"
Set rng = ActiveDocument.Range
With rng.Find
.Text = "Type:"
Do While .Execute
iBookmarkSuffix = iBookmarkSuffix + 1
ActiveDocument.Bookmarks.Add strBookMarkPrefix & iBookmarkSuffix, rng
Loop
End With
End Sub
Sub bmEndPermitType()
'
' bmEndPermitType
'
'
Dim rng2 As Range
Dim iBookmarkSuffix As Integer
Dim strBookMarkPrefix
strBookMarkPrefix = "BMEndPermitType"
Set rng = ActiveDocument.Range
With rng.Find
.Text = "Amount due:"
Do While .Execute
iBookmarkSuffix = iBookmarkSuffix + 1
ActiveDocument.Bookmarks.Add strBookMarkPrefix & iBookmarkSuffix, rng
Loop
End With
End Sub
Bookmarks are OK, but might be "too flexible" - They can even start in the middle of a table cell and end in a the middle of another paragraph. I suggest you to try doing it with Content Controls - their appearance might also be more suitable for your scenario. Check this link.
If you can write a simple .NET application, there is mail merge toolkit that will make your task much more easy. It will allow you to create word document that will act as a template (it also uses Content Controls for tagging) which you will be able to populate with data from your .NET application. And it demands only couple of lines of code to write.