I am trying to simply create an Excel sheet with lots of formatting in it from Access via VBA.
With this example I'm just trying to select A1 to E1 and turn the color of the cells to the color blue with a left border to each cell yet nothing happens, the Excel file opens but it just sits there and does nothing. What am I missing?
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlWorkbook As Excel.Workbook
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkbook = xlApp.Workbooks.Add
Set xlSheet = xlWorkbook.Sheets(1)
With xlSheet.Range("A1:E1").Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
With xlSheet.Range("A1:E1").Borders(xlEdgeLeft)
This only applies a border to the left of A1.
Specify each cell:
With xlSheet.Range("A1,B1,C1,D1,E1").Borders(xlEdgeLeft)
or use a loop:
Dim cell As Excel.Range
For Each cell in xlSheet.Range("A1:E1")
With cell.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 5
End With
Next
Note that .ColorIndex is an index into a color palette, not an absolute color. Try the following instead:
.Color = vbBlue
Related
For the purpose of sales department I have a query that tracks previous price points and calculates margins. I would like to export this info to Excel to create a combo chart to make the information more visual. I've found some sample code on another site, but it doesn't quite do everything I need. I've used the macro recorder to come up with my desire code, but it uses different methods than my sample code. Can anyone help me to combine the following codes to come up with Combo Charts via VBA?
'sample code below
Private Sub Command201_Click()
Option Compare Database
Private Const conQuery = "qryTopTenProducts"
Private Const conSheetName = "Top 10 Products"
Private Sub Command201_Click()
Dim rst As ADODB.Recordset
' Excel object variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Dim i As Integer
On Error GoTo HandleErr
' Create Excel Application object.
Set xlApp = New Excel.Application
' Create a new workbook.
Set xlBook = xlApp.Workbooks.Add
' Get rid of all but one worksheet.
xlApp.DisplayAlerts = False
For i = xlBook.Worksheets.Count To 2 Step -1
xlBook.Worksheets(i).Delete
Next i
xlApp.DisplayAlerts = True
' Capture reference to first worksheet.
Set xlSheet = xlBook.ActiveSheet
' Change the worksheet name.
xlSheet.Name = conSheetName
' Create recordset.
Set rst = New ADODB.Recordset
rst.OPEN _
Source:=conQuery, _
ActiveConnection:=CurrentProject.Connection
With xlSheet
' Copy field names to Excel.
' Bold the column headings.
With .Cells(1, 1)
.Value = rst.Fields(0).Name
.Font.Bold = True
End With
With .Cells(1, 2)
.Value = rst.Fields(1).Name
.Font.Bold = True
End With
' Copy all the data from the recordset
' into the spreadsheet.
.Range("A2").CopyFromRecordset rst
' Format the data.
.Columns(1).AutoFit
With .Columns(2)
.NumberFormat = "#,##0"
.AutoFit
End With
End With
' Create the chart.
Set xlChart = xlApp.Charts.Add
With xlChart
.ChartType = xlComboColumnClusteredLine
.SetSourceData xlSheet.Cells(1, 1).CurrentRegion
.PlotBy = xlColumns
.Location _
Where:=xlLocationAsObject, _
Name:=conSheetName
End With
' Setting the location loses the reference, so you
' must retrieve a new reference to the chart.
With xlBook.ActiveChart
.HasTitle = True
.HasLegend = False
With .ChartTitle
.Characters.Text = conSheetName & " Chart"
.Font.Size = 16
.Shadow = True
.Border.LineStyle = xlSolid
End With
With .ChartGroups(1)
.GapWidth = 20
.VaryByCategories = True
End With
.Axes(xlCategory).TickLabels.Font.Size = 8
.Axes(xlCategoryScale).TickLabels.Font.Size = 8
End With
' Display the Excel chart.
xlApp.Visible = True
ExitHere:
On Error Resume Next
' Clean up.
rst.Close
Set rst = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
Exit Sub
HandleErr:
MsgBox Err & ": " & Err.Description, , "Error in CreateExcelChart"
Resume ExitHere
End Sub
'macro recorded code
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Range("'PART TARGET'!$A$1:$E$5")
ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(1).AxisGroup = 1
ActiveChart.FullSeriesCollection(2).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(2).AxisGroup = 1
ActiveChart.FullSeriesCollection(3).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(3).AxisGroup = 1
ActiveChart.FullSeriesCollection(4).ChartType = xlLine
ActiveChart.FullSeriesCollection(4).AxisGroup = 1
ActiveChart.FullSeriesCollection(5).ChartType = xlLine
ActiveChart.FullSeriesCollection(5).AxisGroup = 1
ActiveChart.FullSeriesCollection(4).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(4).AxisGroup = 2
ActiveChart.FullSeriesCollection(3).ChartType = xlLine
The problem breaks into two parts. Exporting the data to Excel and then having Excel create a Combo Chart. If you are creating the Excel file you can use Access's Export Data Wizard to create a saved export of almost anything in access. Then its a simple call to:
DoCmd.RunSavedImportExport "Export-MyTabletoExcel"
If you already have an Excel File with a macro for creating the chart from where the data goes then you can create the chart by simply calling the macro from Access
runExcelMacro "C:\Users\bubblegum\Desktop\test2.xlsm", "CreateComboChart"
Public Sub runExcelMacro(wkbookPath, macroName)
'adapted from https://access-excel.tips/run-excel-macro-from-access-vba/
Dim XL As Object
Set XL = CreateObject("Excel.Application")
With XL
.Visible = False
.displayalerts = False
.Workbooks.Open wkbookPath
.Run macroName
.ActiveWorkbook.Close (True)
.Quit
End With
Set XL = Nothing
End Sub
But if you have to create the Excel file it will not have a Macro yet so it is best to create that macro in Excel then translate it to Access vba:
Sub CreateComboChart()
' CreateComboChart Macro
Range("B1:D7").Select
ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.SetSourceData Source:=Range("Table4!$B$1:$D$7")
ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(1).AxisGroup = 1
ActiveChart.FullSeriesCollection(2).ChartType = xlColumnClustered
ActiveChart.FullSeriesCollection(2).AxisGroup = 1
ActiveChart.FullSeriesCollection(3).ChartType = xlLine
ActiveChart.FullSeriesCollection(3).AxisGroup = 1
End Sub
became:
Public Sub CreateComboChartinExcel()
'Required: Tools > Refences: Add reference to Microsoft Excel Object Library
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlChart As Excel.Chart
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open("C:\Users\bubblegum\Desktop\test.xlsm")
Set xlSheet = xlBook.ActiveSheet
xlSheet.Range("B1:D7").Select
xlSheet.Shapes.AddChart2(201, xlColumnClustered).Select
Set xlChart = xlBook.ActiveChart
xlChart.SetSourceData Source:=xlSheet.Range("B1:D7")
xlChart.FullSeriesCollection(1).ChartType = xlColumnClustered
xlChart.FullSeriesCollection(1).AxisGroup = 1
xlChart.FullSeriesCollection(2).ChartType = xlColumnClustered
xlChart.FullSeriesCollection(2).AxisGroup = 1
xlChart.FullSeriesCollection(3).ChartType = xlLine
xlChart.FullSeriesCollection(3).AxisGroup = 1
xlBook.Save 'surprisingly important
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
End Sub
Finally, the Access Export Wizard neither lets you append the exported data to the Excel file or lets you see the VBA. So if you want to paste to an Excel file you have to either use Docmd.TransferSpreadsheet or loop through the Access tables and copy and paste to excel. I show Docmd:
Public Sub TransferTable()
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "myTable", "C:\Users\bubblegum\Desktop\test.xlsx"
End Sub
I'm working witht he following code:
Sub AddTrendLinesBoth()
Dim myCht As ChartObject
Dim oTren As Trendline
Dim oWb As Workbook
Dim oWS As Worksheet
Set oWb = ThisWorkbook
Set oWS = oWb.Sheets("Summary")
Set myCht = oWS.ChartObjects("Chart 1")
On Error GoTo GetOut
With myCht.Chart
.SeriesCollection(1).Trendlines.Add
.SeriesCollection(2).Trendlines.Add
End With
Set oTren = myCht.SeriesCollection(1).Trendlines(1)
With oTren.Format.Line
.Visible = msoTrue
.Weight = 3
.ForeColor.RGB = RGB(112, 48, 160)
.Transparency = 0
End With
Set oTren = myCht.SeriesCollection(2).Trendlines(1)
With oTren.Format.Line
.Visible = msoTrue
.Weight = 3
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
GetOut:
End Sub
On each instance of set oTren = the code errors out on establishing the variable. What am I missing to adequately establish that line?
The reason I'm using with statements as set variables, is because using ActiveChart and ActiveSheet was throwing method errors with older versions of Excel.
The problem is that myCht is a ChartObject object rather than a Chart object. You thus need to go through the chart object's chart method to get to the elements of the chart, such as trendlines associated to series:
Set oTren = myCht.Chart.SeriesCollection(1).Trendlines(1)
I am trying to copy charts from excel to PPT in a PPT macro using a function. Though, when I try to run the function it says "Subscript out of range" on the line indicated below and I am really confused why.
Public dlgOpen As FileDialog
Public folder As String
Public excelApp As Object
Public xlWorkBook As Object
Public xlWorkBook2 As Object
Public PPT As Presentation
Public Name1 As String
Public Name2 As String
Public rng1 As Range
Public rng2 As Range
Dim NamedRange As Range
Public Sub GenerateVisual()
Set PPT = ActivePresentation
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = True
Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls")
xlWorkBook.Sheets("MarketSegmentTotals").Activate
xlWorkBook.ActiveSheet.Shapes.AddChart.Select
xlWorkBook.ActiveChart.ChartType = xlColumnClustered
xlWorkBook.ActiveChart.SetSourceData Source:=xlWorkBook.ActiveSheet.Range("MarketSegmentTotals!$A$1:$F$2")
xlWorkBook.ActiveChart.Legend.Delete
xlWorkBook.ActiveChart.SetElement (msoElementChartTitleAboveChart)
xlWorkBook.ActiveChart.SetElement (msoElementDataLabelCenter)
xlWorkBook.ActiveChart.ChartTitle.Text = "DD Ready by Market Segment"
xlWorkBook.ActiveSheet.ListObjects.Add
With xlWorkBook.ActiveChart.Parent
.Top = 100 ' reposition
.Left = 100 ' reposition
End With
Set xlWorkBook2 = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\GeneralTotals.xls")
xlWorkBook2.Sheets("Totals").Activate
xlWorkBook2.ActiveSheet.Shapes.AddChart.Select
xlWorkBook2.ActiveChart.ChartType = xlColumnClustered
xlWorkBook2.ActiveChart.SetSourceData Source:=xlWorkBook2.ActiveSheet.Range("Totals!$A$1:$C$2")
xlWorkBook2.ActiveChart.Legend.Delete
xlWorkBook2.ActiveChart.SetElement (msoElementChartTitleAboveChart)
xlWorkBook2.ActiveChart.SetElement (msoElementDataLabelCenter)
xlWorkBook2.ActiveChart.ChartTitle.Text = "Total DD Ready"
xlWorkBook2.ActiveSheet.ListObjects.Add
With xlWorkBook2.ActiveChart.Parent
.Top = 100 ' reposition
.Left = 100 ' reposition
End With
Set rng1 = xlWorkBook.Sheets("MarketSegmentTotals").Range("B8:F25")
Set rng2 = xlWorkBook2.Sheets("Totals").Range("A8:C25")
Call RangeToPresentation("MarketSegmentTotals", rng1)
Call RangeToPresentation("Totals", rng2)
'Set dlgOpen = Application.FileDialog(Type:=msoFileDialogFolderPicker)
'
'dlgOpen.Show
'dlgOpen.Title = "Select Report Location"
'
'folder = dlgOpen.SelectedItems(1)
End Sub
Public Function RangeToPresentation(sheetName, NamedRange)
Dim ppApp As Object
Dim ppPres As Object
Dim PPSlide As Object
Set ppApp = GetObject(, "Powerpoint.Application")
Set ppPres = ppApp.ActivePresentation
ppApp.ActiveWindow.ViewType = ppViewNormal
' Select the last (blank slide)
longSlideCount = ppPres.Slides.Count
ppPres.Slides(1).Select
Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)
xlWorkBook.Sheets(sheetName).Range(NamedRange.Address).CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
' Paste the range
PPSlide.Shapes.Paste.Select
'Set the image to lock the aspect ratio
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue
'Set the image size slightly smaller than width of the PowerPoint Slide
ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10
ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10
'Shrink image if outside of slide borders
If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = 600
End If
' Align the pasted range
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End Function
I think that you are mixing Ranges. Please try the code posted below, which contains quite a few modifications from your original code. I detail below the main ones. You have to set a reference to the Microsoft Excel vvv Object Library. In the VBE, use Tools -> References.
Main changes:
Declared the type of arguments in your Function.
Changed the Function to Sub (you only perform actions, you do not return a value).
Used NamedRange directly. There is no need for the convoluted way in which you used it. The first argument is now superfluous (you may remove it).
Used variables to refer to objects. This allows for much easier coding and debugging.
Removed some of the Select and Activate. You should not use them unless strictly needed (apparently this is not the case).
There are still quite a few points where you can improve your code, in particular along the lines set above.
Please first try it. If it does not work, use the debugger, watches and the immediate window to explore deeper, and give feedback.
Option Explicit
Public dlgOpen As FileDialog
Public folder As String
Public excelApp As Object
Public xlWorkBook As Excel.Workbook
Public xlWorkBook2 As Excel.Workbook
Public PPT As Presentation
Public Name1 As String
Public Name2 As String
Public rng1 As Excel.Range
Public rng2 As Excel.Range
Dim NamedRange As Excel.Range
Dim xlws As Excel.Worksheet
Dim xlsh As Excel.Shape
Dim xlch As Excel.Chart
Dim xlws2 As Excel.Worksheet
Dim xlsh2 As Excel.Shape
Dim xlch2 As Excel.Chart
Public Sub GenerateVisual()
Set PPT = ActivePresentation
Set excelApp = CreateObject("Excel.Application")
excelApp.Visible = True
Set xlWorkBook = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\MarketSegmentTotals.xls")
Set xlws = xlWorkBook.Sheets("MarketSegmentTotals")
Set xlsh = xlws.Shapes.AddChart
Set xlch = xlsh.Chart
With xlch
.ChartType = xlColumnClustered
.SetSourceData Source:=xlws.Range("$A$1:$F$2")
.Legend.Delete
.SetElement (msoElementChartTitleAboveChart)
.SetElement (msoElementDataLabelCenter)
.ChartTitle.Text = "DD Ready by Market Segment"
End With
xlws.ListObjects.Add
With xlch.Parent
.Top = 100 ' reposition
.Left = 100 ' reposition
End With
Set xlWorkBook2 = excelApp.workbooks.Open("C:\Users\wzawisa\Downloads\GeneralTotals.xls")
Set xlws2 = xlWorkBook.Sheets("Totals")
'xlWorkBook2.Sheets("Totals").Activate
Set xlsh2 = xlws2.Shapes.AddChart
Set xlch2 = xlsh2.Chart
With xlch2
.ChartType = xlColumnClustered
.SetSourceData Source:=xlws2.Range("$A$1:$C$2")
.Legend.Delete
.SetElement (msoElementChartTitleAboveChart)
.SetElement (msoElementDataLabelCenter)
.ChartTitle.Text = "Total DD Ready"
End With
xlWorkBook2.ActiveSheet.ListObjects.Add
With xlws2.Parent
.Top = 100 ' reposition
.Left = 100 ' reposition
End With
Set rng1 = xlws.Range("B8:F25")
Set rng2 = xlws2.Range("A8:C25")
Call RangeToPresentation("MarketSegmentTotals", rng1)
Call RangeToPresentation("Totals", rng2)
'Set dlgOpen = Application.FileDialog(Type:=msoFileDialogFolderPicker)
'
'dlgOpen.Show
'dlgOpen.Title = "Select Report Location"
'
'folder = dlgOpen.SelectedItems(1)
End Sub
Public Sub RangeToPresentation(ByVal sheetName As String, NamedRange As Excel.Range)
Dim ppApp As Object
Dim ppPres As Object
Dim PPSlide As Object
Set ppApp = GetObject(, "Powerpoint.Application")
Set ppPres = ppApp.ActivePresentation
ppApp.ActiveWindow.ViewType = ppViewNormal
' Select the last (blank slide)
Dim longSlideCount As Integer
longSlideCount = ppPres.Slides.Count
ppPres.Slides(1).Select
Set PPSlide = ppPres.Slides(ppApp.ActiveWindow.Selection.SlideRange.SlideIndex)
NamedRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
' Paste the range
PPSlide.Shapes.Paste.Select
'Set the image to lock the aspect ratio
ppApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoTrue
'Set the image size slightly smaller than width of the PowerPoint Slide
ppApp.ActiveWindow.Selection.ShapeRange.Width = ppApp.ActivePresentation.PageSetup.SlideWidth - 10
ppApp.ActiveWindow.Selection.ShapeRange.Height = ppApp.ActivePresentation.PageSetup.SlideHeight - 10
'Shrink image if outside of slide borders
If ppApp.ActiveWindow.Selection.ShapeRange.Width > 700 Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = 700
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Height > 600 Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = 600
End If
' Align the pasted range
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
' Clean up
Set PPSlide = Nothing
Set ppPres = Nothing
Set ppApp = Nothing
End Sub
I have a routine that pastes any recordset into an existing workbook from an MS Access database. The code works fine the first time, but I can never run it twice because it leaves one instance of Excel running in the Task Manager. Of course, this causes an error when I refer to Excel objects in my code the 2nd, 3rd, etc. time, because the objects are ambiguous.
For the sake of missing anything here is the entire code:
'I call the routine like so:
Private Sub cmdGenerateRpt
Dim strPath As String
strPath = "C:\Test\MyReport.xlsx"
Call PushToExistingExcel("MAIN SHEET", strPath)
End sub
Public Sub PushToExistingExcel(strSheetToPlaceData As String, strPathToWorkbook As String)
'Puts a recordset into a specific cell of an Excel workbook
Dim xlApp As Object
Dim wb As Object
Dim xlSheet As Object
Dim rs As DAO.Recordset
Dim rsTotals As DAO.Recordset
Dim x As Integer
Dim fld As Variant
Dim intRecords As Integer
Dim intTotals As Integer
Set xlApp = CreateObject("Excel.Application")
Set wb = xlApp.Workbooks.Open(strPathToWorkbook)
Set xlSheet = wb.Sheets(strSheetToPlaceData) 'or you can manually type the sheet name in place of strSheetToPlaceData
Set rs = CurrentDb.OpenRecordset("Select * from qryRPT")
Set rsTotals = CurrentDb.OpenRecordset("Select * from qryTOTALS")
intRecords = rs.RecordCount
intTotals = intRecords + 3
xlSheet.Select
xlSheet.Range("A3:AH3").Select
xlSheet.Range(Selection, Selection.End(xlDown)).Select
'PLACE
xlSheet.Range("A3").CopyFromRecordset rs
xlSheet.Range("L" & intRecords + 3).CopyFromRecordset rsTotals
Cells.EntireColumn.AutoFit
xlSheet.Range("A1").Select
Range("A" & intTotals & ":AH" & intTotals).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Selection.NumberFormat = "$#,##0.00"
Range("A" & intTotals).Value = "TOTALS"
wb.Save
MsgBox "Done"
xlApp.Visible = True
'If I use xlApp.quit it quits, but still leaves it running in task manager
Set wb = Nothing
Set xlSheet = Nothing
Set rs = Nothing
Set rsTotals = Nothing
Set xlApp = Nothing
End Sub
At the end of the day, I want for the finished Workbook to open up presenting itself to the user. There is no reason to just say that the report is done - 'go look for it'.
But I can't seem to figure out how to get rid of the instance of Excel left over from VBA.
In order to clean up successfully, you need to
destroy all objects that refer to objects in the Excel App
close all workbooks
Quit the app
Also, to avoid any mistakes and to create cleaner code you should
avoid use of the implicit ActiveSheet. The unqualified references to Cells. ..., Range( ..., Selection. ... may be leaving references to the Excel app hanging. Use variables for all references
avoid Select, Selection etc
See this answer for help on avoiding these
Cleanup code should be
Set xlSheet = Nothing
For Each wb In xlApp.Workbooks
wb.Close False
Next
xlApp.Quit
Set xlApp = Nothing
This one is closer to 'air tight.' In addition to avoiding using '.select' or '.selection any stray reference like cells.EntireColumn.AutoFit was a Gotcha for me.
Note how I tried to stick to 3 variables for Excel - xlApp, wb and xlSheet
Any reference I used needed all three of these tightly integrating the full address. I also used 'Late Binding.'
Then I isolated the presentation of the workbook in another routine.
Use this as an example for pasting a complex query into an existing workbook at a specified location and presenting the report. It works nicely!
Public Sub PushToExistingExcel(strSheetToPlaceData As String, strPathToWorkbook As String)
'Puts a recordset into a specific cell of an Excel workbook
Dim xlApp As Object
Dim wb As Object
Dim xlSheet As Object
Dim rs As DAO.Recordset
Dim rsTotals As DAO.Recordset
Dim x As Integer
Dim fld As Variant
Dim intRecords As Integer
Dim intTotals As Integer
Set xlApp = CreateObject("Excel.Application")
Set wb = xlApp.Workbooks.Open(strPathToWorkbook)
Set xlSheet = wb.Sheets(strSheetToPlaceData) 'or you can manually type the sheet name in place of strSheetToPlaceData
Set rs = CurrentDb.OpenRecordset("Select * from qryRPT")
Set rsTotals = CurrentDb.OpenRecordset("Select * from qryTOTALS")
intRecords = rs.RecordCount
intTotals = intRecords + 3
xlSheet.Rows("3:" & xlSheet.Rows.Count).ClearContents
'PLACE
With xlSheet
.Range("A3").CopyFromRecordset rs
.Range("L" & intRecords + 3).CopyFromRecordset rsTotals
.Cells.EntireColumn.AutoFit
End With
With xlSheet.Range("A" & intTotals & ":AH" & intTotals).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With xlSheet.Range("A" & intTotals & ":AH" & intTotals).Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 11
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
xlSheet.Range("A3:AH" & intTotals).NumberFormat = "$#,##0.00"
xlSheet.Range("A" & intTotals).Value = "TOTALS"
wb.Save
'cleanup
Set xlSheet = Nothing
For Each wb In xlApp.Workbooks
wb.Close False
Next
Set rs = Nothing
Set rsTotals = Nothing
xlApp.Quit
Set xlApp = Nothing
MsgBox "Report Complete"
PresentExcel (strPathToWorkbook)
End Sub
Public Sub PresentExcel(strPath As String)
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
xlApp.Workbooks.Open strPath
Debug.Print xlApp.Version
Set xlApp = Nothing
End Sub
I have been attempting to develop a routine that will highlight every nth row on a range in Excel from an Access database.
This eliminates a lot of the different code offerings on the subject since most leverage the embedded Excel functions.
The code below is a stand alone extraction from my Access VBA that I have been using for testing in hopes that I could find the correct parameter structure to make it work. As such, the code includes some Dim statements, etc that would not be required if I were embedding this macro directly as an Excel macro.
The code I have accomplishes selecting every other row but for some reason, only the first column of the intended range. I have not been able to resolve this problem and include the other columns in the formating process.
Any assistance would be much appreciated.
Sub xxx()
Dim xlbook As Excel.Workbook
Dim xlRng As Range
Dim xlFinalRange As Range
Dim intColumnCount As Integer
Dim introwcount As Integer
Dim strTable As String
Set xlbook = Excel.ThisWorkbook
strTable = "Sheet1"
introwcount = 20
intColumnCount = 14
Set xlFinalRange = Sheets(strTable).Range("A4")
xlFinalRange.Resize(1, intColumnCount).Select
Set xlRng = Sheets(strTable).Range("A4")
xlRng.Resize(1, intColumnCount).Select
intRowsBetween = 2
For i = 0 To introwcount
Set xlRng = xlRng.Offset(intRowsBetween, 0)
xlRng.Resize(1, intColumnCount).Select
Set xlFinalRange = xlbook.Application.Union(xlFinalRange, xlRng)
xlFinalRange.Resize(1, intColumnCount).Select
i = i + (intRowsBetween - 1)
Next i
xlFinalRange.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End Sub
The best way is to add a proper Step to your loop. Also, qualify everything properly: Range should be Excel.Range, etc. Try the following:
Sub HighlightXL()
Dim WBK As Excel.Workbook
Dim WS As Excel.Worksheet
Dim Iter As Long
Dim CombinedRng As Excel.Range, IterRng As Excel.Range
Excel.Application.Visible = True
Set WBK = Excel.Workbooks.Add 'Modify as necessary.
Set WS = WBK.Sheets("Sheet1") 'Modify as necessary.
With WS
For Iter = 1 To 22 Step 3 '1, 4, 7, 9... etc...
Set IterRng = .Cells(Iter, 1).Resize(1, 5) 'Resize to 14 in your case.
If CombinedRng Is Nothing Then
Set CombinedRng = IterRng
Else
Set CombinedRng = Union(CombinedRng, IterRng)
End If
Next Iter
End With
CombinedRng.Interior.ColorIndex = 3 'Red.
End Sub
Screenshot:
Let us know if this helps. :)
I have taken a slightly different approach in the past. Below is what I would use:
Sub ColourSheet()
Dim ApXL As Object, xlWBk As Object, xlWSh As Object, _
rng As Object, c As Object
Dim strSheet As String, strFile As String
Dim iColourRow As Integer, iRows As Integer, _
iCols As Integer, x As Integer, iStartRow As Integer
strFile = "C:\YourFolder\YourFile.xlsx"
strSheet = "SheetName"
iColourRow = 3
iRows = 30
iCols = 10
iStartRow = 2
If SmartGetObject("Excel.Application") Then
'excel open
Set ApXL = GetObject(, "Excel.Application")
Else
Set ApXL = CreateObject("Excel.Application")
End If
Set xlWBk = ApXL.Workbooks.Add
'Set xlWBk = ApXL.Workbooks.Open(strFile)
Set xlWSh = xlWBk.activesheet
'Set xlWSh = xlWBk.Worksheets(strSheet)
For x = 1 To iRows
If x Mod iColourRow = 0 Then
With xlWSh.range(xlWSh.cells(iStartRow + x - 1, 1), _
xlWSh.cells(iStartRow + x - 1, iCols)).interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
'.ThemeColor = xlThemeColorAccent1
.Color = 255
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
End If
Next x
ApXL.Visible = True
End Sub
A few notes:
Especially if you plan to distribute your database I would advise using late binding for references to Excel, if you use VBA references sooner or later someone's database will stop working and you'll reach the conclusion it is due to a missing reference. Search Late Binding and you'll see plenty on the subject. Note that with late binding you don't get the variables such as xlThemeColorAccent1, you can always get these from opening an Excel VBA instance etc.
I have used a Function call GetSmartObject which identifies if you have Excel running already, a problem I ran into quite a bit was opening additional Excel instances, hitting an error and then that instance remaining running in the background, you then need to go into Task Manager to close it.
Lastly I have just commented out the alternate workbook open where you open a designated file and set the sheet, testing it was easier to open a new workbook and use the active sheet.
Hope this helps
Function SmartGetObject(sClass As String) As Integer
Dim oTmpObject As Object
' If Server running, oTmpObject refers to that instance.
' If Server not running Error 429 is generated.
On Error Resume Next
Set oTmpObject = GetObject(, sClass)
' oTmpObject is reference to new object.
If Err = 429 Then
SmartGetObject = False
Exit Function
' Server not running, so create a new instance:
'Simon noted out: Set oTmpObject = GetObject("", sClass)
' NOTE: for Excel, you can add the next line to view the object
' oTmpObject.Visible = True
ElseIf Err > 0 Then
MsgBox Error$
SmartGetObject = False
Exit Function
End If
Set oTmpObject = Nothing
SmartGetObject = True
End Function
Credit for the above function belongs elsewhere but I've had it so long I don't know where it came from, if anyone can tell me I'll credit it correctly in future.
Option Compare Database
Option Explicit
Sub ExporttoExcel()
Dim i As Integer
Dim y As Integer
Dim varArray As Variant 'Used for obtaining the Names of the Sheets from the DB being exported
Dim varField As Variant 'Used for Naming of the Sheets being exported
Dim dbs As DAO.Database
Dim rst1 As DAO.Recordset 'DB Recordset for the Input and Output information
Dim rst2 As DAO.Recordset 'DB Recordset for the Table names to be exported and sheet names in Excel
Dim rst3 As DAO.Recordset 'DB Recordset that is reused for each Table being exported
Dim strFile As String 'Used for the name and location of the Excel file to be saved
Dim strTable As String 'Table name being exported and also used for the Sheet name
Dim strTitle As String 'Title for the Data on each sheet
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim xlRunning As Boolean 'Flag to identify that Excel is running or not
Dim intColumnCount As Integer 'The number of columns on a sheet for formatting
Dim intRowCount As Integer 'The number of rows on a sheet for formatting
Dim intStartRow As Integer 'The row from which to start the highlighting process
Dim intRowsBetween As Integer 'The number of rows between highlighting
If SmartGetObject("Excel.Application") Then
Set xlApp = GetObject(, "Excel.Application") 'Excel is already open so the existing instance will be used
xlRunning = True
Else
Set xlApp = CreateObject("Excel.Application") 'Excel is not open so an instance will be created
xlRunning = False
End If
Set xlBook = xlApp.Workbooks.Add
xlApp.Visible = True
xlApp.DisplayAlerts = False
Set dbs = CurrentDb
'Retrieve Study Location and Name for Import to Database
Set rst1 = dbs.OpenRecordset("StudyTarget")
strFile = rst1!OutputFile
' Removed VBA for File Name & Save Path Information
With xlBook
Set rst2 = dbs.OpenRecordset("ExportTableGroup", dbOpenSnapshot)
' Removed VBA for Excel Naming information from DB
For y = 0 To rst2.RecordCount - 1
strTable = varArray(y, 1)
strTitle = varArray(y, 2)
Set rst3 = dbs.OpenRecordset(strTable, dbOpenTable)
.Sheets.Add after:=Sheets(Sheets.Count)
.Sheets(Sheets.Count).Name = strTable
Set xlSheet = .ActiveSheet
'COPY the Access Table Data to the Named Worksheet
xlSheet.Cells(2, 1).CopyFromRecordset rst3
'Select every X number of rows between sheet Data Rows on Worksheet to highlight
intRowsBetween = 2
intStartRow = 4
For i = 0 To intRowCount Step intRowsBetween
If xlSheet.Cells(intStartRow + i, 1) = "" Then
Exit For
End If
With xlSheet.Range(xlSheet.Cells(intStartRow + i, 1), _
xlSheet.Cells(intStartRow + i, intColumnCount)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = RGB(186, 186, 186)
.TintAndShade = 0.6
.PatternTintAndShade = 0
End With
Next i 'Next Row
Next 'Next Table
.Sheets("sheet1").Delete
.Sheets(1).Select 'Go to first sheet of workbook
End With
Export_to_Excel_Exit:
rst1.Close
rst2.Close
rst3.Close
xlApp.ActiveWorkbook.Save
xlBook.Close
If xlRunning Then 'Check to see if used an existing instance of Excel via SmartGetObject
Else
xlApp.Quit
Set xlApp = Nothing
End If
Set xlBook = Nothing
Set rst1 = Nothing
Set rst2 = Nothing
Set rst3 = Nothing
Set dbs = Nothing
Exit Sub