I've written a routine that deletes checkboxes and labels which are dynamically added to a sheet. However, it doesn't realiably delete all the controls. I need to ensure they are completely removed before adding again.
Here is my routine:
Public Sub removeOLEtypesOfType()
On Error Resume Next
Dim intPass As Integer, objShape As Shape
For intPass = 1 To 2
For Each objShape In ActiveSheet.Shapes
Dim strName As String
strName = objShape.Name
If Mid(strName, 1, Len(CHECKBOX_PREFIX)) = CHECKBOX_PREFIX _
Or Mid(strName, 1, Len(LABEL_PREFIX)) = LABEL_PREFIX _
Or Mid(strName, 1, 5) = "Label" Then
objShape.Delete
End If
Next
Next
End Sub
I only added the two pass for loop to ensure the objects are deleted, but even this doesn't delete the remaining items. The issue I have is that I end up with controls that were not deleted in the workbook.
I'm only trying to delete checkboxes and labels where in the case of checkboxes the name is prefixed with:
Public Const CHECKBOX_PREFIX As String = "chkbx"
Labels are prefixed with:
Public Const LABEL_PREFIX As String = "lbl"
The 3rd search comparing with 'Label' is an attempt to mop up but even this doesn't catch all.
Is there any way to delete all shapes / ole objects within a range?
Fixed, I rewrote the sub-routine after a google search on how to delete shapes within a range:
Public Sub removeOLEtypesOfType()
On Error Resume Next
Dim objTopLeft As Range, objBotRight As Range
Dim objRange As Range, objShape As Shape
Set objRange = Sheet1.Range(COLUMN_HEADINGS)
With objRange
Set objTopLeft = .Cells(1).Address(0, 0)
Set objBotRight = .cell(.Cells.Count).Address(0, 0)
For Each objShape In ActiveSheet.Shapes
If Mid(objShape.Name, 1, Len(CHECKBOX_PREFIX)) = CHECKBOX_PREFIX _
Or Mid(objShape.Name, 1, Len(LABEL_PREFIX)) = LABEL_PREFIX Then
If Not Intersect(objTopLeft, objShape.TopLeftCell) Is Nothing And _
Not Intersect(objBotRight, objShape.BottomRightCell) Is Nothing Then
objShape.Delete
End If
End If
Next
End With
End Sub
Related
Thanks in advance, not sure why this wouldn't work.
I want to assign a macro to each button inside a shape group on load.
Inside Module:
Private Const SideNavName As String = "SideNav"
Public Sub SetSideNavigationOnAllSheets()
Dim ws As Worksheet
Dim oShape As Shape
For Each ws In ActiveWorkbook.Sheets
'check to see if sidenav shape/group exists in sheet
If Common.ShapeExists(ws, SideNavName) Then
' get side nav
For Each oShape In ws.Shapes(SideNavName).GroupItems
' only need the nav buttons not container
If Left(oShape.Name, 3) = "Nav" Then
Debug.Print ws.Name, oShape.Name
oShape.TextFrame.Characters.Text = "btn 1" ' pull from DB
oShape.OnAction = "'" & ActiveWorkbook.Name & "'!FolderSelectorButton" ' ERRORS OUT HERE
End If
'
Next
End If
Next
End Sub
Public Sub FolderSelectorButton()
Debug.Print 1
End Sub
Seems VBA doesn't like setting the OnAction property for Shapes that have been grouped. Solution is to store details of the group, ungroup it, update the OnAction property then re-create the group.
Replace your two lines setting the TextFrame and OnAction of the oShape object with the following:
' save then ungroup the Shapes
Dim oShpGrp As Shape, sShapeNames() As String, i As Long
Set oShpGrp = ws.Shapes(SideNavName)
ReDim sShapeNames(1 To oShpGrp.GroupItems.Count)
For i = 1 To oShpGrp.GroupItems.Count
sShapeNames(i) = oShpGrp.GroupItems.Item(i).Name
Next i
oShpGrp.Ungroup
' update Shape
oShape.TextFrame.Characters.Text = "btn 1" ' pull from DB
oShape.OnAction = "'" & ActiveWorkbook.Name & "'!FolderSelectorButton" ' ERRORS OUT HERE
' re-group the Shapes
Set oShpGrp = oShpGrp.Parent.Shapes.Range(sShapeNames).Group
oShpGrp.Name = SideNavName
This assumes that the group is a single-level group (ie it is not a group embedded within another group)
I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
I am using Application.Caller in a subroutine that I programmatically tied to the OnAction property of all the shapes I find on a worksheet. Application.Caller returns the name of the shape which initiated the call so that I can then obtain the appropriate shape object to process.
All of this is fine unless there is more than one shape on the sheet with the same name making it impossible to determine which is the caller. Excel manages the naming when inserting, copying and pasting shapes manually in a worksheet but these worksheets are populated through external apps which can cause this naming redundancy.
I am currently managing this by first scanning and renaming the redundant shapes so that I can identify them with the Application.Caller function. However, I do not want to rename them.
Code I've tried:
Set objShape = Application.Caller - unfortunately does not work
iShapeID = Application.Caller.ID - unfortunately does not work
iShapeID = ActiveSheet.Shapes(Application.Caller).ID - works but does not identify the correct caller when there are shapes with the same name
So, my question is: How can I obtain the proper Application.Caller shape object when there are redundantly named shapes on the worksheet?.
Put another way: Is there a way to cast the Application.Caller to a shape object without using the name of the shape returned by Application.Caller ideally using the ID property of the shape?
I don't think there is a an alternative for Application.Caller to return the ID property of the Shape or some other 'trick' to achieve what you want.
The work-around is to ensure that all your Shapes have unique names. If you have a sheet of names with duplicates you can quickly make them unique by re-naming them to preserve the original duplicate but add a suffix e.g. _1 to make them unique.
The sub could work like this (using a Dictionary to track the suffix value):
Sub MakeShapeNamesUnique(ws As Worksheet)
Dim shp As Shape
Dim dic As Object
Dim lng As Long
Set dic = CreateObject("Scripting.Dictionary")
'iterate shapes
For Each shp In ws.Shapes
' does shape name exist ?
If Not dic.Exists(shp.Name) Then
' add name to dictionary if not exists with counter of 0
dic.Add shp.Name, 0
Else
' found a duplicate
' increment counter
dic(shp.Name) = dic(shp.Name) + 1
' rename shape with suffix indicating dupe index
shp.Name = shp.Name & "_" & dic(shp.Name)
End If
Next shp
' job done - clean up the dictionary
Set dic = Nothing
End Sub
Here's the full test code that creates your issue and uses MakeShapeNamesUnique to work-around the problem. If you want to try it out, put it in a blank workbook because it will delete shapes out of the sheet before it starts:
Option Explicit
Sub Test1()
Dim ws As Worksheet
Dim shp As Shape
' reset shapes
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each shp In ws.Shapes
shp.Delete
Next shp
' add shape
With ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 100, 100)
.Name = "Foo1"
.OnAction = "ShapeAction"
End With
' add another shape
With ws.Shapes.AddShape(msoShapeRectangle, 160, 10, 100, 100)
.Name = "Foo2"
.OnAction = "ShapeAction"
End With
' add another shape with duplicate name
With ws.Shapes.AddShape(msoShapeRectangle, 310, 10, 100, 100)
.Name = "Foo1"
.OnAction = "ShapeAction"
End With
' add another shape with duplicate name
With ws.Shapes.AddShape(msoShapeRectangle, 10, 160, 100, 100)
.Name = "Foo2"
.OnAction = "ShapeAction"
End With
' add another shape with duplicate name
With ws.Shapes.AddShape(msoShapeRectangle, 160, 160, 100, 100)
.Name = "Foo1"
.OnAction = "ShapeAction"
End With
' add another shape
With ws.Shapes.AddShape(msoShapeRectangle, 310, 160, 100, 100)
.Name = "Foo3"
.OnAction = "ShapeAction"
End With
' uniqueify shape names - comment out to replicate OP problem
MakeShapeNamesUnique ws
End Sub
Sub ShapeAction()
Dim shp As Shape
Set shp = Sheet1.Shapes(Application.Caller)
MsgBox " My name is: " & shp.Name & " and my ID is: " & shp.ID
End Sub
Sub MakeShapeNamesUnique(ws As Worksheet)
Dim shp As Shape
Dim dic As Object
Dim lng As Long
Set dic = CreateObject("Scripting.Dictionary")
'iterate shapes
For Each shp In ws.Shapes
' does shape name exist ?
If Not dic.Exists(shp.Name) Then
' add name to dictionary if not exists with counter of 0
dic.Add shp.Name, 0
Else
' found a duplicate
' increment counter
dic(shp.Name) = dic(shp.Name) + 1
' rename shape with suffix indicating dupe index
shp.Name = shp.Name & "_" & dic(shp.Name)
End If
Next shp
' job done - clean up the dictionary
Set dic = Nothing
End Sub
Counter must be unique, also when adding shapes between.
Sub MakeShapeNamesUnique(ws As Worksheet)
Dim shp As Shape
Dim dic As Object
Dim lng As Long
Set dic = CreateObject("Scripting.Dictionary")
'iterate shapes
For Each shp In ws.Shapes
' does shape name exist ?
If Not dic.Exists(shp.Name) Then
' add name to dictionary if not exists with counter of 0
dic.Add shp.Name, 0
Else
' found a duplicate
' increment counter (must be unique)
Do
dic(shp.Name) = dic(shp.Name) + 1
Loop Until Not dic.Exists(shp.Name & "_" & dic(shp.Name))
' rename shape with suffix indicating dupe index
shp.Name = shp.Name & "_" & dic(shp.Name)
End If
Next shp
' job done - clean up the dictionary
Set dic = Nothing
End Sub
I'm having a problem assigning VBA generated ActiveX checkboxes to a class module. When a user clicks a button, the goal of what I am trying to achieve is: 1st - delete all the checkboxes on the excel sheet; 2nd - auto generate a bunch of checkboxes; 3rd - assign a class module to these new checkboxes so when the user subsequently clicks one of them, the class module runs.
I've borrowed heavily from previous posts Make vba code work for all boxes
The problem I've having is that the 3rd routine (to assign a class module to the new checkboxes) doesn't work when run subsequently to the first 2 routines. It runs fine if run standalone after the checkboxes have been created. From the best I can tell, it appears VBA isn't "releasing" the checkboxes after they have been created to allow the class module to be assigned.
The below code is the simplified code that demonstrates this problem. In this code, I use a button on "Sheet1" to run Sub RunMyCheckBoxes(). When button 1 is clicked, the class module did not get assigned to the newly generated checkboxes. I use button 2 on "Sheet1" to run Sub RunAfter(). If button 2 is clicked after button 1 has been clicked, the checkboxes will be assigned to the class module. I can't figure out why the class module won't be assigned if just the first button is clicked. Help please.
Module1:
Public mcolEvents As Collection
Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Call SetCBAction("Sheet1")
End Sub
Sub DeleteAllCheckboxesOnSheet(SheetName As String)
Dim obj As OLEObject
For Each obj In Sheets(SheetName).OLEObjects
If TypeOf obj.Object Is MSForms.CheckBox Then
obj.Delete
End If
Next
End Sub
Sub InsertCheckBoxes(SheetName As String, CellRow As Double, CellColumn As Double, CBName As String)
Dim CellLeft As Double
Dim CellWidth As Double
Dim CellTop As Double
Dim CellHeight As Double
Dim CellHCenter As Double
Dim CellVCenter As Double
CellLeft = Sheets(SheetName).Cells(CellRow, CellColumn).Left
CellWidth = Sheets(SheetName).Cells(CellRow, CellColumn).Width
CellTop = Sheets(SheetName).Cells(CellRow, CellColumn).Top
CellHeight = Sheets(SheetName).Cells(CellRow, CellColumn).Height
CellHCenter = CellLeft + CellWidth / 2
CellVCenter = CellTop + CellHeight / 2
With Sheets(SheetName).OLEObjects.Add(classtype:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=CellHCenter - 8, Top:=CellVCenter - 8, Width:=16, Height:=16)
.Name = CBName
.Object.Caption = ""
.Object.BackStyle = 0
.ShapeRange.Fill.Transparency = 1#
End With
End Sub
Sub SetCBAction(SheetName)
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets(SheetName).OLEObjects
If TypeName(o.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckBoxes = o.Object
mcolEvents.Add cCBEvents
End If
Next
End Sub
Sub RunAfter()
Call SetCBAction("Sheet1")
End Sub
Class Module (clsActiveXEvents):
Option Explicit
Public WithEvents mCheckBoxes As MSForms.CheckBox
Private Sub mCheckBoxes_click()
MsgBox "test"
End Sub
UPDATE:
On further research, there is a solution posted in the bottom answer here:
Creating events for checkbox at runtime Excel VBA
Apparently you need to force Excel VBA to run on time now:
Application.OnTime Now ""
Edited lines of code that works to resolve this issue:
Sub RunMyCheckboxes()
Dim i As Double
Call DeleteAllCheckboxesOnSheet("Sheet1")
For i = 1 To 10
Call InsertCheckBoxes("Sheet1", i, 1, "CB" & i & "1")
Call InsertCheckBoxes("Sheet1", i, 2, "CB" & i & "2")
Next
Application.OnTime Now, "SetCBAction" '''This is the line that changed
End Sub
And, with this new formatting:
Sub SetCBAction() ''''no longer passing sheet name with new format
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In Sheets("Sheet1").OLEObjects '''''No longer passing sheet name with new format
If TypeName(o.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckBoxes = o.Object
mcolEvents.Add cCBEvents
End If
Next
End Sub
If OLE objects suit your needs then I'm glad you've found a solution.
Are you aware, though, that Excel's Checkbox object could make this task considerably simpler ... and faster? Its simplicity lies in the fact that you can easily iterate the Checkboxes collection and that you can access its .OnAction property. It is also easy to identify the 'sender' by exploiting the Evaluate function. It has some formatting functions if you need to tailor its appearance.
If you're after something quick and easy then the sample below will give you an idea of how your entire task could be codified:
Public Sub RunMe()
Const BOX_SIZE As Integer = 16
Dim ws As Worksheet
Dim cell As Range
Dim cbox As CheckBox
Dim i As Integer, j As Integer
Dim boxLeft As Double, boxTop As Double
Set ws = ThisWorkbook.Worksheets("Sheet1")
'Delete checkboxes
For Each cbox In ws.CheckBoxes
cbox.Delete
Next
'Add checkboxes
For i = 1 To 10
For j = 1 To 2
Set cell = ws.Cells(i, j)
With cell
boxLeft = .Width / 2 - BOX_SIZE / 2 + .Left
boxTop = .Height / 2 - BOX_SIZE / 2 + .Top
End With
Set cbox = ws.CheckBoxes.Add(boxLeft, boxTop, BOX_SIZE, BOX_SIZE)
With cbox
.Name = "CB" & i & j
.Caption = ""
.OnAction = "CheckBox_Clicked"
End With
Next
Next
End Sub
Sub CheckBox_Clicked()
Dim sender As CheckBox
Set sender = Evaluate(Application.Caller)
MsgBox sender.Name & " now " & IIf(sender.Value = 1, "Checked", "Unchecked")
End Sub
I have an Access 2010 application where I run a SQL query and output the results to Excel. I'm using the Excel subtotal command to create subtotals. That works fine, but on the total rows only the text ("XXX Count") is bold and the values are not bold. Our client would like the entire row bold. I've tried a couple ways without success. How do I do the entire row in the subtotals?
So here is what I currently have:
This is correct except I need all of row 5, 8, 16, and 17 bold like this:
Here is my code to create the Excel file from Access (this all works except for the bold issues):
Public Sub ExportToExcel(query)
Dim appXL As Object
Dim wbk As Object
Dim wksNew As Object
Set appXL = CreateObject("Excel.Application")
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets("Sheet1")
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Set appXL = CreateObject("Excel.Application")
appXL.Visible = True
Set wbk = appXL.Workbooks.Add
Set wksNew = wbk.Worksheets(1)
Set cn = CurrentProject.AccessConnection
Set rs = New ADODB.Recordset
With rs
Set .ActiveConnection = cn
.Source = query
.Open
End With
With rs
'Put recordset into new wks
wksNew.Cells(2, 1).CopyFromRecordset rs
'And add headers
Dim i As Long
For i = 0 To .Fields.Count - 1
wksNew.Cells(1, i + 1).Value = .Fields(i).Name
wksNew.Cells(1, i + 1).Font.Bold = True
wksNew.Cells(1, i + 1).HorizontalAlignment = xlCenter
Next i
'Now, while the recordset is available...
'The recordset has .fields.count fields
'Subtotals are wanted from field 7 to the end
If .Fields.Count > 13 Then
ReDim ary(14 To .Fields.Count - 1)
For i = LBound(ary) To UBound(ary)
ary(i) = i
Next i
wksNew.Cells(1, 1).CurrentRegion.SubTotal GroupBy:=1, _
TotalList:=ary, Replace:=True, PageBreaks:=False, SummaryBelowData:=True
End If
.Close
End With
End Sub
I tried this code based on this website:
Dim rCell As Range
wksNew.Columns("A:A").Select
Dim rCell As Range
For Each rCell In Selection
If Right(rCell.Value, 5) = "Count" Then
Rows(rCell.Row).Interior.ColorIndex = 36
End If
Next
but it returned a "Method or data member not found" error on the item rCell.Value.
I also tried it like this:
Dim rCell As Range
wksNew.Columns("A:A").Select
For Each rCell In Selection
If Right(rCell, 5) = "Count" Then
Selection.Font.Bold = True
End If
Next
But I got the error "ActiveX component can't create object" on the For Each line.
How do I bold the entire row for the subtotals?
You're getting an error because Access doesn't know what Selection is unless you tell it that it's connected to your Excel instance.
For Each rCell In Selection
However, don't need to select anything, or check the whole column:
Dim rCell As Range
For Each rCell In wksNew.UsedRange.Columns(1).Cells
If Right(rCell, 5) = "Count" Then
rCell.Font.Bold = True
End If
Next
Have you tried a Pivot Table?? It is easier to manage format or layout and you don't have to change too much your code because you just put your RecordSet in a PivotTableCache like the second example in this.
Rather than looping, I'd suggest collapsing the outline and formatting the visible cells:
with wksNew.Cells(1, 1).CurrentRegion
.Outlinelevel = 2
.specialcells(12).Font.Bold = True
.Outlinelevel = 3
End With
Thanks for all the suggestions. No one posted a solution that worked entirely, so here's what I ended up using:
Dim c As Object
For Each c In wksNew.Range("A1:A500")
If c.Value Like "*Total" Then
c.Offset(0, 13).Font.Bold = True
c.Offset(0, 14).Font.Bold = True
c.Offset(0, 15).Font.Bold = True
End If
Next
The only thing that concerns me is that I'm assuming this only has 500 rows. I couldn't find a way to find the number of rows and have it search only those. If I included the whole column, it took a couple minutes to complete the loop which I didn't think the client would like. Any suggestions on how to find the last row?
I would
Display level 2 of the outline, all the subtotals
Select the whole area
Use GoTo Special to select only visible cells
Apply the formatting
Change the header row formatting if it should be different
Display all the levels again (level 3)
This code demonstrates:
Sub Macro4()
Application.ScreenUpdating = False
ActiveSheet.Outline.ShowLevels RowLevels:=2
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Font.Bold = True
'change the header row if necessary
Range(Range("A1"), Range("A1").End(xlToRight)).Font.Italic = True
ActiveSheet.Outline.ShowLevels RowLevels:=3
End Sub