Excel striping using VBA from an Access database

Question

Excel striping using VBA from an Access database

I am trying to develop a procedure that will select every nth row in a range in Excel from an Access database.

This eliminates many different code suggestions on this, as most use Excel's built-in functions.

The code below is a self-extract from my VBA access, which I used for testing, in the hope that I can find the correct parameter structure to make it work. Thus, the code includes some Dim instructions, etc., which would not be required if I embed this macro directly in the Excel macro.

The code I execute selects every other row, but for some reason, only the first column of the intended range. I could not solve this problem and include other columns in the formation process.

Any help would be greatly 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

+3

vba

Richard Feb 24 '14 at 21:31

source share

3 answers

Manhattan · Answer 1 · 2014-02-24T22:08:13+0000

The best way is to add the correct tag Stepto your loop. In addition, qualify everything correctly: it Rangeshould 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. :)

Simon1979 · Answer 2 · 2014-02-24T22:09:47+0000

In the past, I used a slightly different approach. Below I will 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:

, , Excel, VBA , - , , . Late Binding, . , , xlThemeColorAccent1, Excel VBA ..

GetSmartObject, , Excel, , , Excel, , , , .

, , , , .

,

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

, , , , - , .

Richard · Answer 3 · 2014-02-26T22:20:53+0000

    Option Compare Database

Explicit option

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

Excel striping using VBA from an Access database

More articles: