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
Related
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?
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 but when I try to apply the Hidden behavior on the whole row then VBA through an error.
Getting error on below the line
Selection.Font.Hidden = True
Below is my whole code
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\DE\DE\International_DE.docx"
Set WrdDoc = WrdApp.Documents.Open(FileStr)
SearchArr = Array("French", "Spanish")
'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.Select
Selection.Font.Hidden = True
End If
Next TblCell
Next Arrcnt
Next Cnt
End Sub
Can anyone help me out to understand where i am doing issue so, i can rectify it.
I think it's more effective to reduce the row height to an exact minimum value.
Something like this works for me.
Sub Test()
SearchArr = Array("sdg", "sdh", "dsf")
'loop tables
For Cnt = 1 To ActiveDocument.Tables.Count
'loop search word
For Arrcnt = LBound(SearchArr) To UBound(SearchArr)
'loop through table cells
For Each tblCell In ActiveDocument.Tables(Cnt).Range.Cells
Set aRng = tblCell.Range
If InStr(LCase(aRng), LCase(SearchArr(Arrcnt))) Then
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).HeightRule = wdRowHeightExactly
ActiveDocument.Tables(Cnt).Rows(tblCell.RowIndex).Height = 1
End If
Next tblCell
Next Arrcnt
Next Cnt
End Sub
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
I'm trying to write a VBA code in MS Word 2016 in order to fill cells containing a certain string ("–" in my case). I have tried something like this:
Sub CellsColorFill()
Dim tTable As Table
Dim cCell As Cell
For Each tTable In ActiveDocument.Range.Tables
For Each cCell In tTable.Range.Cells
If cCell.Range = "-" Then
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603923969
End If
Next
Next
Set oCell = Nothing
Set tTable = Nothing
End Sub
However, for some reason, it has no effect when executed. How could this task be done?
Note - It is good to have Option Explicit at the top of the module to help you point out undeclared variable. oCell is not declared and I assume it's a typo of cCell
To check if a string contains a certain string, you can use InStr to check if returns a non-0 value (0 means not found)
Option Explicit
Sub CellsColorFill()
Dim tTable As Table
Dim cCell As Cell
For Each tTable In ActiveDocument.Range.Tables
For Each cCell In tTable.Range.Cells
If InStr(cCell.Range.Text, "-") <> 0 Then
cCell.Shading.Texture = wdTextureNone
cCell.Shading.ForegroundPatternColor = wdColorAutomatic
cCell.Shading.BackgroundPatternColor = -603923969
End If
Next
Next
End Sub
I'm trying to check every section of a document for images or grouped images and, if they're found, create a table with 1 row and 2 columns at the beginning of that section, where the first column will contain the text (with original formatting) and the second column will contain the images. I have converted all the images in the document to inline shapes.
Edit: In the document, there's random amounts of text (and/or other characters) before, after and in between a random amount of images. Sometimes a section has no text and only images. For each section, I would like all of the text (with original formatting and in the order in which it occurs) to be contained in the first column, and all images and grouped images (also in their same order) to be contained in the second folder. Ideally, if the only things on the page are a heading and an image, they would be put into a 1x1 table (with the heading above the image).
I've tried a few variations of this with no success. Generally stuff starts getting pretty messy because I have no idea what I'm doing. I've left out the text in this code because it was only complicating things, but I would like to move the text as well.
Sub ToTables()
Dim iShp As InlineShape
Dim oRng As Range
Dim oTbl As Table
Dim i As Integer
Dim a As Integer
Dim b As Integer
a = ActiveDocument.BuiltInDocumentProperties("Number of Sections")
For i = 1 To a
Set oRng = ActiveDocument.GoTo(What:=wdGoToSection, Name:=i)
Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\section")
If Right(oRng, 1) = vbCr Then _
oRng = Left(oRng, Len(oRng) - 1)
b = oRng.InlineShapes.Count
If b >= 1 Then
oRng.Collapse Direction:=wdCollapseStart
Set oTbl = oRng.Tables.Add(oRng, 1, 2, AutoFitBehavior:=wdAutoFitContent)
For Each iShp In oRng.InlineShapes
iShp.Select
Selection.Cut
oTbl.Cell(1, 2).Range.Paste
Next iShp
End If
Next i
End Sub
Thanks
Try the revised code:
Sub Demo()
Application.ScreenUpdating = False
Dim Sctn As Section, Rng As Range, Tbl As Table, s As Long, w As Single
For Each Sctn In ActiveDocument.Sections
Set Rng = Sctn.Range: w = 0
Rng.End = Rng.End - 1
Set Tbl = Rng.ConvertToTable(, NumRows:=1, NumColumns:=1, InitialColumnWidth:=50, AutoFit:=True)
With Tbl
.Columns.Add
For s = .Range.InlineShapes.Count To 1 Step -1
With .Range.InlineShapes(s)
If .Width > w Then w = .Width
.Range.Rows(1).Cells(2).Range.FormattedText = .Range.FormattedText
.Delete
End With
Next
.Columns(1).Cells.Merge
.Columns(2).Cells.Merge
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
If w > 0 Then .Columns(2).Width = w + .LeftPadding + .RightPadding
.Rows.HeightRule = wdRowHeightAuto
End With
Next
Application.ScreenUpdating = True
End Sub
Assuming the text precedes the inlineshapes:
Sub Demo()
Application.ScreenUpdating = False
Dim iShp As InlineShape
For Each iShp In ActiveDocument.InlineShapes
With iShp.Range
.Characters.First.Previous = vbTab
.Start = .Paragraphs.First.Range.Start
.ConvertToTable vbTab, 1, 2
End With
Next
Application.ScreenUpdating = True
End Sub
The above code assumes there is a single character between the text & inlineshape. That character could be a space, paragraph break, line break, anything at all.