I have a large number of reports which have multiple tables that need to have their heading color adjusted. I'm running into an issue with tables who have vertically merged cells in the header though. Here's the code:
Sub Recolor_Table()
Dim Doc_Table As Table
For Each Doc_Table In ActiveDocument.Tables
If Doc_Table.Style Like "*Non-Results Table*" Then
'Since this will match "*Results Table*" as well, check it first
Doc_Table.Rows(1).Shading.BackgroundPatternColor = 12566463 'Grey
ElseIf Doc_Table.Style Like "*Results Table*" Then
Doc_Table.Rows(1).Shading.BackgroundPatternColor = 8406272 'Blue
End If
Next Doc_Table
End Sub
This fails with the following error message:
Run-time error '5991':
Cannot access individual rows in this collection because the table has vertically merged cells
I tried adjusting to a loop through each cell in the table, but found that tables in word do not have a .cells property, so a For each cell in table.cells style loop wouldn't work.
Is there any other way to do this? Possibly editing the table style directly?
The Table object doesn't have a Cells property, but the Table.Range object does, so:
For Each cel in Table.Range.Cells
should work:
Sub LoopCellsInTableWithMergedCells()
Dim tbl As word.Table
Dim cel As word.Cell
Set tbl = ActiveDocument.Tables(1)
For Each cel In tbl.Range.Cells
Debug.Print cel.rowIndex, cel.ColumnIndex
Next
End Sub
Related
I would like to create a macro which will change the "Vertical Alignment" to "Middle" of the selected rows/cells in a PowerPoint table. Can anyone pls help me with this.
Below example snapshot attached.
Below is the code. My code is perfectly working with the shape but could't work for the tables. pls assist.
ActiveWindow.Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
To approach a table you can not use the Shape Object, but need to use Tables.
You can also format only Cell by Cell so you need to run a loop through all Rows and Columns
-----edited-----
To use the selected cells you have to iterate through all cells and see if they are selected
Sub SelectedCells()
Dim oTbl As table
Dim iIdx As Integer
Dim iIdy As Integer
Set oTbl = ActiveWindow.Selection.ShapeRange(1).table
For iIdx = 1 To oTbl.Rows.Count
For iIdy = 1 To oTbl.Columns.Count
If oTbl.Cell(iIdx, iIdy).Selected Then
With oTbl.Cell(iIdx, iIdy).Shape
.TextFrame.VerticalAnchor = msoAnchorTop
End With
End If
Next
Next
End Sub
I dimmed the variable:
Dim mainTableRange As Range
Then gave it a value:
Set mainTableRange = Range("tLedgerData") ' tLedgerData is an Excel table.
Now I'm trying to get the name of the table (which is "tLedgerData") from the variable to reference columns in that table even if the table name changes.
I tried
mainTableRange.Name
and
mainTableRange.Name.Name
(See how do you get a range to return its name.) Both threw run-time error '1004': Application defined or object-defined error.
mainTableRange.Select selected all table data excluding the header and total rows.
I think you're having an X-Y problem here: solving problem X when the solution is for problem Y.
[...] to reference columns in that table even if the table name changes
Have the table / ListObject alone on its own dedicated worksheet, and give the sheet a CodeName. That way you can do this:
Dim tbl As ListObject
Set tbl = LedgerDataSheet.ListObjects(1)
And now you have the almighty power of the ListObject API to do whatever it is that you want to do. For example, retrieve the column names:
Dim i As Long
For i = 1 To tbl.ListColumns.Count
Debug.Print tbl.ListColumns(i).Name
Next
In other words, you don't need to care for the name of the table. What you want is to work with its ListObject. And since you never need to refer to it by name, the table's name is utterly irrelevant and the user can change it on a whim, your code won't even notice.
I believe an Excel table and named-range are two different things which is why the .name.name doesn't work. A table is a ListObject and once you set a range equal to a table you should be able to continue to call that range without an error.
Curious, what is the reason why your table might change unexpectedly?
I wrote out some lines of code to show a couple things. You can create tables and reuse the range variables after the table name changes. You can also set AlternativeText for the table with some identifying string and use that to locate a particular table if you suspect the table name may change.
Option Explicit
Public TestTable As Range
Sub CreateTable()
ActiveSheet.ListObjects.Add(xlSrcRange, [$A$1:$C$4], , xlYes).name = "Table1"
ActiveSheet.ListObjects("Table1").AlternativeText = "Table1"
End Sub
Sub SetTableRange()
Set TestTable = Range("Table1")
End Sub
Sub SelectTable()
TestTable.Select
End Sub
Sub RenameTable()
ActiveSheet.ListObjects("Table1").name = "Table2"
[A1].Select
End Sub
Sub SelectRenamedTable()
TestTable.Select
End Sub
Sub ClearSelection()
[A1].Select
End Sub
Sub FindTable1()
Dim obje As ListObject
For Each obje In ActiveSheet.ListObjects
If obje.AlternativeText = "Table1" Then
MsgBox "Found " & obje.AlternativeText & ". Its current name is: " & obje.name
End If
Next obje
End Sub
Sub ConvertTablesToRanges()
' I found this snippet in a forum post on mrexcel.com by pgc01 and modified
Dim rList As Range
On Error Resume Next
With ActiveSheet.ListObjects("Table1")
Set rList = .Range
.Unlist ' convert the table back to a range
End With
With ActiveSheet.ListObjects("Table2")
Set rList = .Range
.Unlist ' convert the table back to a range
End With
On Error GoTo 0
With rList
.Interior.ColorIndex = xlColorIndexNone
.Font.ColorIndex = xlColorIndexAutomatic
.Borders.LineStyle = xlLineStyleNone
End With
End Sub
I know that this probably isn't the most ideal way to to do this but just bear with me.
I have a document with a few tables on it. I'm using a userform to search the tables/sub-categories and return the relevant values. I want to select the sub categories with a range of option buttons on a userform, these will in turn set the range for the search function to look within. I also want to dynamically update the option buttons if a new table was to be added or anything along those lines.
The only thing that differentiates the title of a sub-category/table, and the items within it, is that the title of a sub-category/table is bold. So what I'm looking to do is search the first column of the spreadsheet and return the names of any entries in bold. These values are then used to set the names of the option buttons :).
The following function is my attempt at finding the text entities in column a that are in bold, returning them and setting each to an individual variable to be used in another function. The bold1 .... variables are all globally defined variables as I need them in another sub, as is the page variable which contains the relevant page to be used. Currently the code returns an error stating "variable or with block not set" and using the debugger I can see that bold1 .... and all the other boldx variables have no value set. Does anybody know whats going on/how to fix this function.
Thanks in advance :)
Sub SelectBold()
Dim Bcell As Range
For Each Bcell In Worksheets(Page).Range("A1:A500")
If Bcell.Font.Bold = True Then
Set bold1 = Bcell
End If
Next
End Sub
EDIT: I simplified the above function, to remove clutter and help narrow in on the issue. I want the above function to store the contents of the found cell (any cell in the document in bold at this stage) in the variable bold1
This will return an array of values from bold cells in column A of Page.
You can fill a combo or list box with theses values using their list property.
ComboBox1.List = getSubCategories("Sheet1")
Function getSubCategories(Page As String) As String()
Dim arrSubCategories() As String
Dim count As Long
Dim c As Range
With Worksheets(Page)
For Each c In .Range("A2", .Range("A" & Rows.count).End(xlUp))
If c.Font.Bold Then
ReDim Preserve arrSubCategories(count)
arrSubCategories(count) = c.Value
count = count + 1
End If
Next
End With
getSubCategories = arrSubCategories
End Function
you may find useful to have a Range returned with subcategories cells found:
Function SelectBold(Page As String, colIndex As String) As Range
With Worksheets(Page)
With .Range(colIndex & "1", .Cells(.Rows.Count, colIndex).End(xlUp)).Offset(, .UsedRange.Columns.Count)
.FormulaR1C1 = "=if(isbold(RC[-1]),"""",1)"
.Value = .Value
If WorksheetFunction.CountA(.Cells) < .Rows.Count Then Set SelectBold = Intersect(.SpecialCells(xlCellTypeBlanks).EntireRow, .Parent.Columns(1))
.Clear
End With
End With
End Function
Function IsBold(rCell As Range)
IsBold = rCell.Font.Bold
End Function
to be possibly exploited as follows:
Option Explicit
Sub main()
Dim subCategoriesRng As Range, cell As Range
Set subCategoriesRng = SelectBold(Worksheets("bolds").Name, "A") '<--| pass worksheet name and column to search in
If Not subCategoriesRng Is Nothing Then
For Each cell In subCategoriesRng '<--| loop through subcategories cells
'... code
Next cell
End If
End Sub
I am trying to insert tables marked with a Name via a bookmark so I can later recognize them again.
Below I have added my source code in question. At pos3 I created a table with 2 rows and add a bookmark for its range. But when repeating the Sub I always end up in the case of pos1 .. my bookmark is not found in the table selection. (trying to reach pos2)
The bookmark itself is added, but maybe not to the table. I suspect the error to be there.
I can see the bookmark in the bookmark-list of Word. But if I do a manual "go to" the cursor seems to end up off screen somewhere, so I suspect its not added correctly to the table range.
Private Sub PrepareFooter()
Dim oSection As Section
Dim oFooter As HeaderFooter
Dim oRng As Range
Dim tbl As Table
Dim cell As cell
Dim foundFooterTable As Boolean
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
With oFooter.Range
For Each tbl In .Tables
tbl.Select
If Selection.Bookmarks.Count <> 1 Then
tbl.Delete ' <-- pos1
ElseIf Selection.Bookmarks(1).Name <> "FooterTable" Then
tbl.Delete
Else
foundFooterTable = True ' <-- pos2
FormatFooterTable tbl
End If
Next
End With
oFooter.Range.Select
Selection.Collapse wdCollapseStart
If Not foundFooterTable Then
Set tbl = ActiveDocument.Tables.Add(Selection.Range, 2, 1)
tbl.Select
ActiveDocument.Bookmarks.Add Range:=Selection.Range
, Name:="FooterTable" ' <- pos3
FormatFooterTable tbl
End If
Next oFooter
Next oSection
End Sub
thanks for any ideas about what I might do wrong!
Try to work without Selection as much as you can. Whenever possible, use a Range object. That will make your code clearer and more reliable.
In order to put a bookmark "around" a table (pos 3):
ActiveDocument.Bookmarks.Add Range:=tbl.Range, Name:="FooterTable"
When this works, you should be able to get the table using:
Dim sFooterTable as String
sFooterTable = "FooterTable"
If ActiveDocument.Bookmarks.Exists(sFooterTable) Then
Set tbl = ActiveDocument.Bookmarks(sFooterTable).Range.Tables(1)
found my mistake:
I was applying the same bookmark name on all tables that were found .. this way deleting the previous bookmarks as they need a unique name.
adding a unique identifier in the end (I used an integer now) made the code work.
I have a list of more than 150 cells which contained hyperlinks to images on local hard,
yesterday I found a way to popup those images by inserting comments with filling the background with a picture.
It will be tough to do this one by one, So I want a VBA script to insert comments on selected cells and fill the comments background with images which its hyperlink located in every cell.
Is That possible or should I do it manually?
Here is an Example of cells contents
I1 D:\My Pictures\example 001.jpg
I2 D:\My Pictures\example 021.jpg
I3 D:\My Pictures\example 030.jpg
Recording a macro shows that the above is possible. A little tweaking is in order, though. As an example, the following macro creates an image pop-up via comment for A1.
Sub Test()
Dim Comm As Comment
On Error Resume Next
Range("A1").AddComment
Range("A1").Comment.Visible = False
Set Comm = Range("A1").Comment
Comm.Shape.Fill.UserTextured "C:\foo\bar.gif"
End Sub
The On Error Resume Next is for handling ranges that already have comments, so you can keep on running the macro repeatedly. I set .Visible to False to be safe that the images don't become permanent pop-ups (should only appear on hover).
We can tweak the above further to create a subroutine that takes in a range and a string as arguments so we can call it repeatedly across ranges.
Sub CreatePopUp(TargetRange As Range, PathToImage As String)
Dim Comm As Comment
On Error Resume Next
With TargetRange
.AddComment
.Comment.Visible = False
Set Comm = .Comment
End With
Comm.Shape.Fill.UserTextured PathToImage
End Sub
The above can be called like so:
Sub MassPopUp()
Dim rCell As Range
For Each rCell In [A1:A10]
CreatePopUp rCell, "Blah"
Next
End Sub
Let us know if this helps.
EDIT:
If your date is in, for example, I1:I10, and they contain the exact paths to the image files, then the above can be written like so:
Sub MassPopUp()
Dim rCell As Range
For Each rCell In [I1:I10]
CreatePopUp rCell, rCell.Value
Next
End Sub
rCell.Value will take the value inside the cell, pass it to the subroutine that inserts an image, and apply it as a comment to rCell with the proper image extracted. This should not fail. Just make sure the value in the cell are proper paths to their respective files.