I'm trying to add borders to a table that I have copied to word from excel. I haven't defined the table name but using the Range.Paste method, does anyone know how to add borders to the table-Below is the code that I am using
ThisWorkbook.Sheets("Participants - C").Range("C7:D13").Copy
docWord.Bookmarks("TransParties").Range.Paste
You can use this code:
Sub test()
'add your code, e.g. set docWord etc. here
ThisWorkbook.Sheets("Participants - C").Range("C7:D13").Copy
With docWord.Bookmarks("TransParties").Range
.Paste
Dim tbl As Word.Table
Set tbl = .Tables(1)
addBorders tbl
End With
End Sub
Private Sub addBorders(tbl As Word.Table)
Dim arrBorders As Variant
'WdBorderType
arrBorders = Array( _
wdBorderBottom, _
wdBorderTop, _
wdBorderLeft, _
wdBorderRight, _
wdBorderVertical, _
wdBorderHorizontal _
)
Dim b As Long
With tbl.Borders
For b = LBound(arrBorders) To UBound(arrBorders)
With .Item(arrBorders(b))
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth050pt
.color = wdColorAutomatic
End With
Next
End With
End Sub
In Word VBA you have to set each border individually :-(
Related
I want to set up a word template, which has a linked excel table via a field with following code:
{LINK Excel.SheetMacroEnabled.12 D:\calendar.xlsm calendar!namedR \f 4 \h \* MERGEFORMAT}
The table resides in excel and is updated daily. The excel has several columns and one of them has a set of hyperlinks to various websites in rows. When I try to break the link to the table, in order to create rest of the document and archive it via the following code, I always get all of the links (including hyperlinks to websites) in the linked table broken.
The funny thing is that when I do it manually and select the table in Word it breaks only the link to the excel table, leaving the hyperlinks in a table column intact. This is the desired programmatic outcome. I tried 2 following macros and none of them works. Is there a way to achieve it via VBA without breaking all the links in a linked table?
Sub ConvertTableLink()
Dim myField As Field
For Each myField In ActiveDocument.Fields
If myField.Type = wdFieldLink Then
myField.Unlink
End If
Next
End Sub
Sub ConvertTableLinkTake2()
ActiveDocument.Fields(1).Update
ActiveDocument.Fields(1).Unlink
End Sub
It's not obvious why your links are remaining when you unlink the LINK field manually but not with VBA. Generally speaking, I see the same behavior whichever way I do it here - the links remain blue so they still look like links, but they aren't.
You can do your own "unlink" that should preserve the hyperlinks using this, assuming the LINK is the first LINK field in the document:
Sub replaceLinkByResult1()
Dim fld As Word.Field
Dim rng As Word.Range
For Each fld In ActiveDocument.Fields
If fld.Type = wdFieldLink Then
Set rng = fld.Result.Tables(1).Range
rng.Copy
fld.Delete
rng.Paste
Exit For
End If
Next
End Sub
If Copy/Paste doesn't work or you prefer to avoid it, the following should also work:
Sub replaceLinkByResult2()
Dim fld As Word.Field
Dim rng1 As Word.Range
Dim rng2 As Word.Range
For Each fld In ActiveDocument.Fields
If fld.Type = wdFieldLink Then
Set rng1 = fld.Result.Tables(1).Range
Set rng2 = rng1.Duplicate
rng2.Collapse wdCollapseEnd
rng2.Start = rng2.Start + 1
rng2.InsertParagraph
rng2.Start = rng2.Start + 1
rng2.FormattedText = rng1.FormattedText
fld.Delete
Set rng2 = Nothing
Set rng1 = Nothing
Exit For
End If
Next
End Sub
For example, assuming the linked object is the first field in the document:
Sub Demo()
Dim Rng As Range, Hlnk As Hyperlink, i As Long
Dim StrDisp As String, StrLink As String, StrFont As String, StrSize As String
With ActiveDocument.Fields(1)
Set Rng = .Result
With Rng
For Each Hlnk In .Hyperlinks
StrDisp = StrDisp & "|" & Hlnk.TextToDisplay
StrLink = StrLink & "|" & Hlnk.Address
StrFont = StrFont & "|" & Hlnk.Range.Font.Name
StrSize = StrSize & "|" & Hlnk.Range.Font.Size
Next
End With
.Unlink
With Rng
For i = 1 To UBound(Split(StrDisp, "|"))
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Format = False
.Text = Split(StrDisp, "|")(i)
.Replacement.Text = ""
.Wrap = wdFindStop
.Execute
End With
Set Hlnk = .Hyperlinks.Add(Anchor:=.Duplicate, Address:=Split(StrLink, "|")(i), TextToDisplay:=Split(StrDisp, "|")(i))
Hlnk.Range.Font.Name = Split(StrFont, "|")(i)
Hlnk.Range.Font.Size = Split(StrSize, "|")(i)
Next
End With
End With
End Sub
I am trying to print out section, that is marked as Printarea. This code however sometimes runs good and sometimes it doesn't. There is really no rule with it. The question is, how can I make it 100% runnable.
What it does when it runs good. It prints the area, saves it as Picture and then quits.
What it does when it doesn't. It prints blank white page without any data on it, as if printing blank page. The fact that the page prints, evethough its blank suggests that the saving is not a problem.
Can you help?
OK, I will reveal my cards. This started as "learning this area of VBA" project (printing saving pictures), so I tried to pull data from website about my arrival to work and then printing what day it is, how far are we with the week so far etc. The whole code is revealed since the fixed range helped a bit, but I still get blank pages in 10% of cases when ran manually and 50% of cases when ran after win start via vbs script. basically I noticed that stressed CPU is in direct correlation to succesful code run. All files are local except for the website pull which is always succesful.
VBS:
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.Run "'*someCorporatePath\newStart.xlsb'!Module1.Auto_Open"
objExcel.DisplayAlerts = False
objExcel.Application.Quit
Set objExcel = Nothing
Module 1
Option Explicit
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" _
(ByVal uAction As Long, ByVal uParam As Long, _
ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPIF_SENDWININICHANGE = &H2
Public Const SPIF_UPDATEINIFILE = &H1
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Sub Auto_Open()
Call getDataFromWebsite
Call weekProgress
Call saveSheet
Call changeWallpaper
Application.DisplayAlerts = False
Application.Quit
End Sub
Sub getDataFromWebsite()
Dim x As String
Dim IE As Object
Dim HtmlCon As HTMLDocument
Dim element As Object
Dim ArrivalTime
On Error GoTo Handler
x = "*Some-secret-corporate-website*"
Set IE = New InternetExplorerMedium
IE.Navigate (x)
IE.Visible = False
Do While IE.ReadyState <> 4
DoEvents
Loop
Set HtmlCon = IE.document
Set element = HtmlCon.getElementsByClassName("*someAJAXcorporateElement*")
ArrivalTime = element(0).innerText
ThisWorkbook.Sheets(1).Cells(3, 15).Value = ArrivalTime
Handler:
IE.Quit
End Sub
Sub weekProgress()
Dim caseResult As String
Dim offsetDayIndex As Integer
Const dayBarLenght = 2
Select Case Application.WorksheetFunction.Weekday(Date, 2)
Case 1
caseResult = "Monday"
offsetDayIndex = 0
Case 2
caseResult = "Tuesday"
offsetDayIndex = 1
Case 3
caseResult = "Wednesday"
offsetDayIndex = 2
Case 4
caseResult = "Thursday"
offsetDayIndex = 3
Case 5
caseResult = "Friday"
offsetDayIndex = 4
Case Else
caseResult = "Monday"
End Select
DoEvents
ThisWorkbook.Sheets(1).Cells(24, 11).Value = caseResult
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 12)).Interior.ColorIndex = 1
If Not caseResult = "Monday" Then
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(31, 5), ThisWorkbook.Sheets(1).Cells(31, 4 + (dayBarLenght * offsetDayIndex))).Interior.ColorIndex = 2
End If
End Sub
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
Dim intLastRow As Integer
Dim intLastCol As Integer
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
With ThisWorkbook.Sheets(1)
.PageSetup.PrintArea = .Range("A1", .Cells(37, 17)).Address
End With
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="*MyCorporatePath*", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
Sub changeWallpaper()
Dim strImagePath As String
strImagePath = "*MyCorporatePath*"
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, strImagePath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub
Requirement: To save the PrintArea of the first worksheet as a bmp file.
Original procedure:
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
oCht.Chart.Paste
oCht.Chart.Export Filename:="C:\Users\insertyourname\Pictures\savedImage.bmp", Filtername:="bmp"
oCht.Delete
Application.DisplayAlerts = True
End Sub
The procedure as originally stated in the post creates a range named area using the PageSetup.PrintArea property as the reference for the range.
If the PrintAreais set to the entire sheet then the PrintArea property would be equal to an empty string and the instruction below will generate an error.
Set area = ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).PageSetup.PrintArea)
As the procedure is printing a blank page, we can assume that the PrintArea property is a valid A1-style reference.
The printing of a blank page when the PageSetup.PrintArea property is a valid A1-style reference could be replicated at least in the following cases:
1. When the range corresponding to the PrintArea is in fact a range of empty cells,
2. When the range corresponding to the PrintArea has its rows or columns hidden,
3. When printing a chart and although the rows and columns of the chart are visible the rows or columns of the Chart.SourceData are hidden, thus the chart is blank.
The original procedure has been adjusted in order to ask the user to validate the output and if the output is blank them it presents the user with the printed range (i.e. the Print.Area) so the necessary corrections can be applied.
Sub Save_PrintArea_As_bmp()
Dim ws As Worksheet
Dim oCht As Object
Dim ddZoomCoef As Double
Dim rArea As Range
Set ws = ThisWorkbook.Worksheets(1) 'Modify as required
With ws
ddZoomCoef = 100 / .Parent.Windows(1).Zoom
Set rArea = .Range(.PageSetup.PrintArea)
rArea.CopyPicture xlPrinter
Set oCht = .ChartObjects.Add(0, 0, _
rArea.Width * ddZoomCoef, rArea.Height * ddZoomCoef)
End With
Application.DisplayAlerts = False
With oCht
.Chart.Paste
If MsgBox("Is the printed page blank?", _
vbQuestion + vbYesNo + vbDefaultButton2, _
"Save PrintArea As bmp") = vbYes Then
.Delete
MsgBox "This is the PrintArea, validate that the range is visible."
With ws
.Activate
Application.Goto .Cells(1), 1
Application.Goto rArea
Exit Sub
Application.DisplayAlerts = True
End With
Else
.Chart.Export Filename:="D:\#D_Trash\savedImage.bmp", _
Filtername:="bmp" 'Modify as required
.Delete
End If: End With
Application.DisplayAlerts = True
End Sub
It sounds like you want to save an image of the area that would be printed, even if the user has not specified a print area. The problem is that Excel has no .PrintArea value if one has not been specified by a user. See below for further details.
To ensure the code works as intended, you can either stop the code early if no print area has been set:
If ThisWorkbook.Sheets(1).PageSetup.PrintArea = vbNullString Then
MsgBox "No print area has been set.", vbCritical, "Save Sheet"
Exit Sub
End If
Or you can set the print area manually to include all values by placing this at the start of the macro:
Dim intLastRow as Integer
Dim intLastCol As Integer
With ThisWorkbook.Sheets(1)
If .PageSetup.PrintArea = vbNullString Then
intLastRow = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
MatchCase:=False).Row
intLastCol = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
MatchCase:=False).Column
.PageSetup.PrintArea = .Range("A1", .Cells(intLastRow, intLastCol)).Address
End If
End With
Note that this closely mimics the default print area to start from A1, but does not include more distant cells that include only formatting or objects. This is likely sufficient for your needs, but it could be adjusted further if you didn't want it to start from A1 or if you need to include cells that contain only formatting or objects.
Notes on "Default Print Area"
There isn't strictly a default print area determined by Excel at the time of printing. It instead prints as many continuous pages as necessary to include all cells that contain any values, formatting or objects, starting from A1 (regardless of where content starts). This is not necessarily a rectangular area and the number of pages printed can depend on the print order. It also does not necessarily include all cells in the .UsedArea
For example, enter a value in W15 (3 pages to the right) and E70 (1 page down). If printing without setting a print area, Excel will start with a blank page from A1. The default print order setting of down-then-across will result in 5 pages being printed from the layout below: Pages 1,4,2,5,3. Changing to print across-then-down will result in only 4 pages being printed: Pages 1,2,3,4. Manually setting the print area instead results in all 6 pages being printed in whichever order is specified.
Upon learning, that Chart.Paste is causing the problem and upon researching in web I found that Chart.Paste is broken terribly in VBA itself. One has to manually activate it through the code. I also found that the printarea is no longer needed since I just passed the desired range to PrintArea and then wrote the PrintArea value to another unknown. So here is the code, that fixes the buggy Chart.Paste
Sub saveSheet()
Dim oCht As Object
Dim zoom_coef
Dim area As Range
Dim intLastRow As Integer
Dim intLastCol As Integer
Dim chartName As String
zoom_coef = 100 / ThisWorkbook.Sheets(1).Parent.Windows(1).Zoom
Set area = Range("A1", Cells(37, 17))
DoEvents
area.CopyPicture xlPrinter
Application.DisplayAlerts = False
DoEvents
Set oCht = ThisWorkbook.Sheets(1).ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
DoEvents
chartName = oCht.Chart.Name
ThisWorkbook.Sheets(1).Activate 'this one **********
oCht.Activate 'this one too ***********
Application.Wait (Now + TimeValue("0:00:02"))
oCht.Chart.Paste
Application.Wait (Now + TimeValue("0:00:02"))
DoEvents
oCht.Chart.Export Filename:="somePath", Filtername:="bmp"
DoEvents
oCht.Delete
Application.DisplayAlerts = True
End Sub
I have this issue with the ComboBox Event Handler.
I managed to create (and fill with items) the Comboboxes I wanted, the code seems to work fine. But after the program has run, if I try to pick one general item inside one of the comboboxes, it seems like the _Change Method is not called --> I cannot handle change events.
Here is my class module (class name: "DB_ComboBox")
Option Explicit
Public WithEvents DB_ComboBoxEvents As MSForms.ComboBox
Private DB_ComboBox_Line As Integer
Private Sub DB_ComboBoxEvents_Change()
MsgBox ("Line : " & DB_ComboBox_Line)
'Here I want handle The comboboxes changes
'But this routine is not called!
End Sub
Sub Box(CBox As MSForms.ComboBox)
Set DB_ComboBoxEvents = CBox
End Sub
Public Property Let Line(value As Integer)
DB_ComboBox_Line = value
End Property
Public Property Get Line() As Integer
Line = DB_ComboBox_Line
End Property
And here is my "Main module", in which I create the comboboxes and pass them to a Collection of "DB_ComboBox"
Sub CreateComboBox(IncCBoxes)
Dim curCombo As MSForms.ComboBox
Dim rng As Range
Dim tot_items As Integer
Dim incAddItem As Integer
Dim incAddItemBis As Integer
Dim itemBaseArray() As String
Dim TEMP_ComboBoxInst As New DB_ComboBox
Set rng = ActiveSheet.Range("J" & IncCBoxes)
Set curCombo = ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height).Object
'Add the items
itemBaseArray = Split(Foglio7.Cells(IncCBoxes, DBColFileComboIndexErrori), ";")
For incAddItem = 0 To UBound(itemBaseArray)
Dim itemLastArray() As String
itemLastArray = Split(itemBaseArray(incAddItem), ",")
For incAddItemBis = 0 To UBound(itemLastArray)
curCombo.AddItem (itemLastArray(incAddItemBis))
Next
Next
TEMP_ComboBoxInst.Box curCombo
TEMP_ComboBoxInst.Line = IncCBoxes
customBoxColl.Add TEMP_ComboBoxInst
End Sub
Can anyone please tell me what I'm missing?
Thank you very much
This looks like a timing-issue:
Running this code in another open file will work. In same file it does not.
Seperate the adding to your class from the adding of the OLEControl i.e.:
use Application.ontime now
see code below:
Private customBoxColl As New Collection
Sub CreateComboBox(IncCBoxes As Long)
Dim curCombo As MSForms.ComboBox
Dim rng As Range
Dim tot_items As Integer
Dim incAddItem As Integer
Dim incAddItemBis As Integer
Dim itemBaseArray() As String
Dim itemLastArray() As String
Set rng = ActiveSheet.Range("J" & IncCBoxes)
With ActiveSheet.OLEObjects.Add(ClassType:="Forms.ComboBox.1", Link:=False, DisplayAsIcon:=False, Left:=rng.Left, Top:=rng.Top, Width:=rng.Width, Height:=rng.Height)
Set curCombo = .Object
End With
'Add the items
itemBaseArray = Split(Foglio7.Cells(IncCBoxes, DBColFileComboIndexErrori), ";")
For incAddItem = 0 To UBound(itemBaseArray)
itemLastArray = Split(itemBaseArray(incAddItem), ",")
For incAddItemBis = 0 To UBound(itemLastArray)
curCombo.AddItem (itemLastArray(incAddItemBis))
Next
Next
Application.OnTime Now, "'CallToClass """ & curCombo.Name & """,""" & IncCBoxes & "'"
End Sub
Sub CalltoClass(ctl As String, myline As Long)
Dim TEMP_ComboBoxInst As New DB_ComboBox
TEMP_ComboBoxInst.Box ActiveSheet.OLEObjects(ctl).Object
TEMP_ComboBoxInst.line = myline
customBoxColl.Add TEMP_ComboBoxInst
End Sub
I know this doesn't apply to your specific problem, but I'll just post this here for any others who may have this problem. In my case, the events stopped firing because I had just copied my database into a new Github repo.
On reopening Access, the events weren't firing while they had been fine the day before, which completely stumped me, especially since none of the SO answers seemed to address my issue. Basically, Access blocks macros and code, and requires it to be reenabled by clicking OK on the little yellow warning at the top of the screen.
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
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