I wish to be able to run a VBA module which manipulates the table that I'm currently in (i.e., the cursor is somewhere within that table). The VBA code will perform an identical operation on each table that you're in when you run it.
So, for example, let's say I have a module which needed to bold the top row of each table (the headings). It would need to locate the table object (called whatever) that you're currently in so that it could manipulate whatever.rows(0).
How can I get the table object from the cursor position? I also need to detect if I'm not in a table and do nothing (or raise an error dialog).
The VBA subroutine at the bottom of this answer shows how to do this.
It uses the current selection, collapsing it to the starting point first so as to not have to worry about multi-segment selections:
Selection.Collapse Direction:=wdCollapseStart
It then checks that selection to ensure it's inside a table
If Not Selection.Information(wdWithInTable) Then
MsgBox "Can only run this within a table"
Exit Sub
End If
The table is then accessible by referring to Selection.Tables(1).
The code below was a simple proof of concept which simply toggled each of the starting cells in each row of the table to either insert or delete a vertical bar marker.
Sub VertBar()
' Collapse the range to start so as to not have to deal with '
' multi-segment ranges. Then check to make sure cursor is '
' within a table. '
Selection.Collapse Direction:=wdCollapseStart
If Not Selection.Information(wdWithInTable) Then
MsgBox "Can only run this within a table"
Exit Sub
End If
' Process every row in the current table. '
Dim row As Integer
Dim rng As Range
For row = 1 To Selection.Tables(1).Rows.Count
' Get the range for the leftmost cell. '
Set rng = Selection.Tables(1).Rows(row).Cells(1).Range
' For each, toggle text in leftmost cell. '
If Left(rng.Text, 2) = "| " Then
' Change range to first two characters and delete them. '
rng.Collapse Direction:=wdCollapseStart
rng.MoveEnd Unit:=wdCharacter, Count:=2
rng.Delete
Else
' Just insert the vertical bar. '
rng.InsertBefore ("| ")
End If
Next
End Sub
I realise this is a rather old question, but I stumbled across some code that may help the next person who is facing a similar problem.
ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.count
This will return the index of the table the cursor is in. Which can then be used to make changes or retrieve information:
dim numberOfColumnsInCurrentTable as Integer
dim currentTableIndex as Integer
currentTableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.count
numberOfColumns = ActiveDocument.Tables(currentTableIndex).Columns.count
Obviously checks should be added to ensure the cursor is within a table.
Related
Whenever I update the document, I need to add a row to the top of the table, just below the headers, and then move the old row to the next level. The table is usually present on the last page of the Word document. Please find attached the screenshot for the expected and actual behaviors.
Below is the code I have written to achieve:
Go to the last page and find the table
Add a row (This adds above the column header)
Expectations:
Add the row immediately after the column header and move the existing row to the next level
Add the date to the second column.
Click for the screenshot
My code:
Sub Macro1()
Selection.EndKey Unit:=wdStory
Dim theTable As Table
Dim theNewRow As Row
For Each theTable In ActiveDocument.Tables
Set theNewRow = theTable.Rows.Add(theTable.Rows.First)
'Other row formatting
Next theTable
End Sub
I am learning VBA and any help would be of great use. Thanks for your time.
screenshot2
As Intellisense shows you the input parameter for Table.Rows.Add is [BeforeRow]. This is an optional parameter so if it is omitted the new row is added after the last row of the table.
As you want the row to come after the first row and before the second you need to pass the second row as the parameter, e.g.
With ActiveDocument.Tables(ActiveDocument.Tables.Count)
With .Rows.Add(.Rows(2))
'add date
.Cells(2).Range.Text = Format(Date, "MMMM d, yyyy")
'add any additional row formatting
End With
End With
For example:
With ActiveDocument
With .Tables(.Tables.Count)
.Split (2)
With .Range.Characters.Last.Next
.FormattedText = .Next.Rows(1).Range.FormattedText
End With
.Rows(2).Range.Delete
End With
End With
It's not clear, though, what you mean by "move the existing row to the next level".
It needs next.
Sub test()
Selection.EndKey Unit:=wdStory
Dim theTable As Table
Dim theNewRow As Row
For Each theTable In ActiveDocument.Tables
Set theNewRow = theTable.Rows.Add(theTable.Rows.First.Next) '<~~ add next
'Other row formatting
Next theTable
End Sub
I'm using this code
Sub Cleanse()
'
' Cleanse Macro
'
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
I had Excel autogenerate it by:
Pressing Record Macro
Going into special
Selecting all blank cells
Using delete selection on the cells
Stop recording Macro
Yet when I undo and run the macro to try and let it do the same thing it says:
you could use this sub
Sub CleanSheet(sht As Worksheet)
On Error Resume Next
Intersect(sht.UsedRange, sht.UsedRange.SpecialCells(xlCellTypeBlanks).EntireRow).EntireRow.Delete
End Sub
to be called by your "Main" Sub as follows
Sub Main()
CleanSheet Worksheets("mySheetToBeCleanedName") '<--| change "mySheetToBeCleanedName" to actual sheet name you want to clear
End Sub
Your error is because your selection (the one you made manually before running the sub) includes the same cell twice, at least once. Edit: this could be due to multiple cells on the same row being empty, then you're selecting the entire row of each of those cells! See code edit below for a fix.
You should try to avoid using Select, despite the Macro Recorder using it a lot. See here: How to avoid using Select in Excel VBA macros
So a better format for your sub would be this:
Sub Cleanse()
' Cleanse Macro for deleting rows where cells in a range are blank
'
Dim myRange as Range
' Set the selection range to the first column in the used range.
' You can use this line to select any range you like.
' For instance if set on manual selection, you could use
' Set myRange = Selection. But this won't solve your actual problem.
Set myRange = ActiveSheet.UsedRange.Columns(1)
' Delete all rows where a cell in myRange was blank
myRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
Edit: Can cycle over all columns like below, avoids overlapping ranges from EntireRow.
Sub Cleanse()
' Cleanse Macro for deleting rows where cells in a range are blank
'
Dim myRange as Range
Dim colNum as Long
' Cycle over all used columns
With ActiveSheet
For colNum = 1 To .UsedRange.Columns.Count + .UsedRange.Columns(1).Column
' Set the selection range to the column in used range.
Set myRange = .UsedRange.Columns(colNum)
' Delete all rows where a cell in myRange was blank
myRange.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next colNum
End With
End Sub
In an excel file of which column A is filled with different dates, sorted in ascending order, the macro should generate a user prompt which asks for a date. The macro should then insert a row between the two dates that are smaller and larger than the date given by the user.
So far, I only achieved to prompt the user for a specific row below which the macro then inserts a new row. Can anyone help me out with the next steps?
Sub addRow()
Dim row
row = InputBox("Maturity date of new bond", "Input maturity date")
If Not row = vbNullString Then
ActiveSheet.Range("A" & row + 1).EntireRow.Insert
End If
End Sub
As I said in the comments I would just iterate through your date column until you find a date that is larger (I said smaller in the comments, but if it's ascending order the larger date will be towards the bottom).
Sub addRow()
Dim givenDate As Date
givenDate = InputBox("Maturity date of new bond", "Input maturity date")
If givenDate <> vbNullString Then
Dim iter As Range
Set iter = ActiveSheet.Range("A1")
Do
Set iter = iter.Offset(1)
Loop While iter.Value <= givenDate
iter.EntireRow.Insert xlDown
Set iter = iter.Offset(-1)
iter.Value = givenDate
End If
End Sub
You'll probably need to do more error checking, but this should do the trick.
Kudos to Taelsin for his answer, but I did notice a few issues with his macro (for example, there is no accounting for the possibility of an invalid date format entered by the user).
Plus, I figured you might want to actually learn what exactly is going on with the code. So, I created the following subroutine with plenty of comments and explanations. I hope it finds you well.
Good luck!
Sub addRow()
' ============================================================================================================
' This is sort of the easy part, taken somewhat from the code you provided. We're going to create some
' variables to use later, and give our user an input field for the maturity date.
' NOTE: You said the date was in column A, but in case that isn't always true, I also use a
' range-selector input box to allow the user to specify the range / column containing maturity dates.
' ============================================================================================================
Dim d As Date ' Create our maturity date
Dim dateColumn As Range ' Create a variable to store our date column
Dim isAscOrder As Boolean ' Create a variable to store a value that will indicate in what direction the dates are sorted
Dim i As Long, j As Long, k As Long, c As Range, r As Range ' Create a few misc variables (I always do this just in case I need them later on)
On Error GoTo cancel ' We want to assume any errors on the next line are caused by the user pressing the "Cancel" button.
Set dateColumn = Application.InputBox("Column containing maturity dates", "Specify maturity date column", Type:=8) ' Show the range-selector input box and store it in our date-column variable
retryDate: ' this is called a "Line Label". We can send user here to retry the next action
On Error GoTo invalidDate ' If the next line causes an error, we will send user to our "invalidDate" label (see below)
d = InputBox("Maturity date of new bond", "Input maturity date") ' Show the input-box and store the date value specified by the user
On Error GoTo 0 ' Set the error-handling back to its default
' ============================================================================================================
' Here comes the slightly more advanced part. The general idea here is that we want to find the spot in which
' this date should fit, but we don't even know in what direction the dates are currently sorted.
' ---------------------------------------------------------------------------------------------------------
' (1) So, first we'll determine the sort direction by comparing the first cell to the last cell.
' Also note that I am specifying "Column(1)" in case the user entered a range with multiple
' columns by mistake.
' (2) Next, I'll loop through each cell in the range using the "For each" statement. Within each
' of these iterations, I will check if the cell's date is greater/less than (this will
' depend on the sort direction) the maturity date specified by the user.
' (3) Finally, when I find a cell that is greater/less than our maturity date, I will insert a
' new row before that row.
' ---------------------------------------------------------------------------------------------------------
' Sound good? Okay, here we go . . .
' ============================================================================================================
isAscOrder = (CDate(dateColumn.Cells(1, 1).Value) < CDate(dateColumn.Columns(1).End(xlDown).Value)) ' compare the first and last cells of the first column to determine the sort direction
For Each c In dateColumn.Columns(1).Cells ' begin the "For Each" loop; this will loop through each cell in the first column of our range
If c.Row() > dateColumn.Parent.UsedRange.Rows.Count() Then Exit Sub ' Proceed only if we have not reached end of the "Used Range" (i.e., the end of our worksheet)
If isAscOrder Then ' If this is in ascending order, then ...
If CDate(c.Value) > d Then ' ... we will check for the first cell greater than our maturity date.
c.EntireRow.Insert shift:=xlShiftDown ' When/if we find it, then insert the new row above the current one, and then ...
Exit Sub ' ... exit the sub (because we are done).
End If
Else ' If this is not in ascending order, then we will assume descending order (duh), and then ...
If CDate(c.Value) < d Then ' ... we will check for the first cell less than our maturity date.
c.EntireRow.Insert shift:=xlShiftDown ' When/if we find it, then insert the new row above the current one, and then ...
Exit Sub ' ... exit the sub (because we are done).
End If
End If
Next c ' No greater/less than date was found; proceed to the next iteration of our "For Each" loop (i.e., the next cell).
' ============================================================================================================
' Our code execution shouldn't come down this far (since we handle all possible scenarios above, and each one
' results in exiting the sub. However, we do need to specify some code to handle our errors.
' ============================================================================================================
Exit Sub ' We shouldn't ever get to this point, but exit the sub just in case.
invalidDate:
If MsgBox("Please enter a valid date (i.e.,""mm/dd/yyyy"")", vbRetryCancel, "Invalid Date") = vbCancel Then ' Display the "invalid date" error, and ask the user if he or she would like to retry. If "Cancel" is clicked, then ...
Exit Sub ' ... exit the sub.
Else ' If the user clicked "Retry", then ...
GoTo retryDate ' ... send them back to the date input box (i.e., the "retryDate" label).
End If
cancel:
Exit Sub
End Sub
I have a macro that I'm using to remove all of the color in all of the tables in certain Word Documents. The colors being removed are there initially to indicate where someone should type.
Trust me, I'd rather use form fields or ActiveX text boxes, but this is not a situation where they will work as Word is being opened through a 3rd party application that invalidates these with a mail merge. Anyway, I want to skip over the first table. I have the code below set up to do it, then change the first cell of the first table back to a particular color.
Sub decolordocument()
'
' decolordocument Macro
'
'
Dim tbl As Table
For Each tbl In ActiveDocument.Tables
tbl.Shading.BackgroundPatternColor = wdColorWhite
Next
ActiveDocument.Tables(1).Cell(1, 1).Shading.BackgroundPatternColor = wdColorLightTurquoise
End Sub
This works fine for removing the color, but the color of that first cell of the first table isn't the same in all of them. I just want to skip the first table during the for each loop. I've tried an if statement (If tbl = ActiveDocument.Tables(1) Then...) but evidently this is not an allowed comparison as it doesn't recognize the Then statement. I've also tried doing this with a range, but couldn't quite get it right. Any thoughts would be appreciated.
Sub decolordocument()
'
' decolordocument Macro
'
'
Dim first as Boolean
Dim tbl As Table
first = true
For Each tbl In ActiveDocument.Tables
If first Then
first = false
Else
tbl.Shading.BackgroundPatternColor = wdColorWhite
End If
Next
'ActiveDocument.Tables(1).Cell(1, 1).Shading.BackgroundPatternColor = wdColorLightTurquoise
End Sub
if activedocument.Tables.Count >1 then
for x = 2 to activedocument.Tables.Count
activedocument.Tables(x).Shading.BackgroundPatternColor = wdColorWhite
next x
end if
It's difficult to tell what is being asked here. This question is ambiguous, vague, incomplete, overly broad, or rhetorical and cannot be reasonably answered in its current form. For help clarifying this question so that it can be reopened, visit the help center.
Closed 10 years ago.
I am a complete beginner in excel and got an assignment today to be completed by tomorrow . I would be really grateful if someone can help me out in this .
I have a sheet which has the following table :
The first table is the master , from which i need to get the data and represent it the form of separate tables using marco-VBA . Would appreciate any help to achieve this using macro .Thanks.
Say the master table has n columns , so I need to form n-1 separate tables where each table will have 2 columns the first column will always be the first column of the master table and the second column will be (n+1)th column from the master table for the nth table . Example - 1st table will have 2 columns (1st column of master table and 2nd column of master table ) , likewise 2nd table will have 2 columns (1st column of master table and 3rd column of master table ) , so on and so forth ....
I will be adding to this answer over the next hour or so. The idea is for you to start with the early blocks of code while I develop later blocks. Edit I have now completed the answer except for any extra explanations you might seek.
I agree with RBarryYoung: you do not provide enough information to allow anyone to provide you with a complete solution. Also, if you are trying to learn VBA, giving you the solution will not help in the long term.
I would normally agree with djphatic: the macro recorder is very useful for learning the VBA that matches user operations but the macro recorder will not give you much of the VBA you need for this task.
I am curious who has given you this assignment when you are clearly not ready for it.
I cannot read your image so I created a worksheet which I named "MasterTable" and loaded it with data so it looks like:
Your comments imply that this table may change in size so the first task is to identify its dimensions. There are many different ways of identifying the dimensions of a table; none of which work in every situation. I will use UsedRange.
Copy the following into a module:
Option Explicit
Sub SplitTable1()
Dim UsedRng As Range
With Worksheets("MasterTable")
Set UsedRng = .UsedRange
Debug.Print UsedRng.Address
Debug.Print UsedRng.Columns.Count
Debug.Print UsedRng.Rows.Count
End With
End Sub
There is no time to give full explanations of everything I will show you but I will try to explain the most important points.
Option Explicit means every variable must be declared. Without this statement, a misspelt name will automatically declare a new variable.
Debug.Print outputs values to the Immediate window which should be at the bottom of the VBA Editor screen. If it is not there, click Ctrl+G.
Dim UsedRng As Range declares a variable UsedRng of type Range. A range is a type of Object. When you assign a value to an object, you MUST start the statement with Set.
Running this macro will output the following to the Immediate window:
$A$1:$H$6
8
6
I will not be using UsedRng.Address or UsedRng.Columns.Count but I wanted you to understand what the UsedRange is and how it can be used.
Add this macro to the module:
Sub SplitTable2()
Dim CellValue() As Variant
Dim ColCrnt As Long
Dim RowCrnt As Long
With Worksheets("MasterTable")
CellValue = .UsedRange.Value
For RowCrnt = LBound(CellValue, 1) To UBound(CellValue, 1)
Debug.Print "Row " & RowCrnt & ":";
For ColCrnt = LBound(CellValue, 2) To UBound(CellValue, 2)
Debug.Print " " & CellValue(RowCrnt, ColCrnt);
Next
Debug.Print
Next
End With
End Sub
Dim CellValue() As Variant declares a dynamic array, CellValue, of type Variant. () means I will declare the size of the array at run time.
CellValue = .UsedRange.Value sets the array CellValue to the values within the UserRange. This statement sets the dimensions of CellValue as required.
CellValue becomes a two dimensional array. Normally the first dimension of an array would be the columns and the second the rows but this is not TRUE when the array is loaded from or to a range.
With a one dimensional array, LBound(MyArray) returns the lower bound of the array and UBound(MyArray) returns the upper bound.
With a two dimensional array, LBound(MyArray, 1) returns the lower bound of the first dimension of the array and LBound(MyArray, 2) returns the lower bound of the second dimension.
This macro outputs the following to the Immediate window.
Row 1: Column 1 Column 2 Column 3 Column 4 Column 5 Column 6 Column 7 Column 8
Row 2: R1C1 R1C2 R1C3 R1C4 R1C5 R1C6 R1C7 R1C8
Row 3: R2C1 R2C2 R2C3 R2C4 R2C5 R2C6 R2C7 R2C8
Row 4: R3C1 R3C2 R3C3 R3C4 R3C5 R3C6 R3C7 R3C8
Row 5: R4C1 R4C2 R4C3 R4C4 R4C5 R4C6 R4C7 R4C8
Row 6: R5C1 R5C2 R5C3 R5C4 R5C5 R5C6 R5C7 R5C8
This second macro demonstrates that I can load all the values from the worksheet into an array and then output them.
Add this macro to the module:
Sub SplitTable3()
Dim ColourBack As Long
Dim ColourFont As Long
With Worksheets("MasterTable")
ColourBack = .Range("A1").Interior.Color
ColourFont = .Range("A1").Font.Color
Debug.Print ColourBack
Debug.Print ColourFont
End With
End Sub
Run this macro and it will output:
16711680
16777215
For this answer, these are just magic numbers. 16777215 sets the font colour to white and 16711680 sets the background or interior colour to blue.
For the last macro, I have created another worksheet "SplitTables".
Add this macro to the module:
Sub SplitTable4()
Dim CellValue() As Variant
Dim ColDestCrnt As Long
Dim ColourBack As Long
Dim ColourFont As Long
Dim ColSrcCrnt As Long
Dim RowDestCrnt As Long
Dim RowDestStart As Long
Dim RowSrcCrnt As Long
With Worksheets("MasterTable")
' Load required values from worksheet MasterTable
CellValue = .UsedRange.Value
With .Cells(.UsedRange.Row, .UsedRange.Column)
' Save the values from the top left cell of the used range.
' This allows for the used range being in the middle of the worksheet.
ColourBack = .Interior.Color
ColourFont = .Font.Color
End With
End With
With Worksheets("SplitTables")
' Delete any existing contents of the worksheet
.Cells.EntireRow.Delete
' For this macro I need different variables for the source and destination
' columns. I do not need different variables for the source and destination
' rows but I have coded the macro as though I did. This would allow the
' UsedRange in worksheet "MasterTable" to be in the middle of the worksheet
' and would allow the destination range to be anywhere within worksheet
' "SpltTables".
' Specify the first row and column of the first sub table. You will
' probably want these both to be 1 for cell A1 but I want to show that my
' code will work if you want to start in the middle of the worksheet.
ColDestCrnt = 2
RowDestStart = 3
' I use LBound when I do not need to because I like to be absolutely
' explicit about what I am doing. An array loaded from a range will
' always have lower bounds of one.
For ColSrcCrnt = LBound(CellValue, 2) + 1 To UBound(CellValue, 2)
' Create one sub table from every column after the first.
'Duplicate the colours of the header row in worksheet "MasterTable"
With .Cells(RowDestStart, ColDestCrnt)
.Interior.Color = ColourBack
.Font.Color = ColourFont
End With
With .Cells(RowDestStart, ColDestCrnt + 1)
.Interior.Color = ColourBack
.Font.Color = ColourFont
End With
RowDestCrnt = RowDestStart
For RowSrcCrnt = LBound(CellValue, 1) To UBound(CellValue, 1)
' For each row in CellValue, copy the values from the first and current
' columns to the sub table within worksheet "SplitTables"
.Cells(RowDestCrnt, ColDestCrnt).Value = _
CellValue(RowSrcCrnt, LBound(CellValue, 2))
.Cells(RowDestCrnt, ColDestCrnt + 1).Value = _
CellValue(RowSrcCrnt, ColSrcCrnt)
RowDestCrnt = RowDestCrnt + 1
Next RowSrcCrnt
ColDestCrnt = ColDestCrnt + 3 ' Advance to position of next sub table
Next ColSrcCrnt
End With
End Sub
This is the real macro. All previous macros have served to demonstrate something. This macro does what I think you want.
Come back with questions. However, I do not know what time zone you are in. It is 23:00 here. I will be going to bed in about an hour. After that questions will be answered tomorrow.
Take a look at the macro recorder within Excel. What you are looking to achieve looks like using VBA to perform simple copy and pastes on specific columns within a table. If you turn the macro recorder on and produce the first table by copying and pasting the variable and estimate columns then hit stop, you can view the code producing by viewing the Visual Basic Editor (Ctrl+F11).
You may find these links of some use:
http://www.automateexcel.com/2004/08/18/excel_cut_copy_paste_from_a_macro/
http://www.techrepublic.com/blog/10things/10-ways-to-reference-excel-workbooks-and-sheets-using-vba/967