Highlighting alternating Excel Sheet Rows using VBA from an Access DB - vba

Question

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

Answer 1

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. :)

Answer 2

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.

Answer 3

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