VBA multi row highlight issue

[Flower76]

Hello,

I am working in Access to export a query to Excel. The number of records varies depending on the parameters selected. If there are more than 1000 records I would like to highlight alternating blocks of 1000 records. I sort of have it working, but not quite the way I would like it. Although I understand the problem, my VBA skills aren't particularly great and I'm having trouble figuring out how to fix my issue.

The problem is that the last block is unlikely to have exactly 1000 records in it, but it's set to highlight 1000 so I need it to look at the selection and only highlight the number of filled cells. The second is that because it alternates colours it also continues 1 block of 1000 past empty cells.

Any help is greatly appreciated!!


----------------------

If rst.RecordCount > 1000 Then

Do Until IsEmpty(ApXL.ActiveCell.Offset(1, 0))

    ApXL.ActiveCell.Range("A2:C" & 1000).Interior.ColorIndex = 15
    

    ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).SELECT
    ApXL.Selection.Resize(1000, 1).SELECT
    ApXL.Selection.Interior.ColorIndex = 2
    
    ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).SELECT
    ApXL.Selection.Resize(1000, 1).SELECT
    ApXL.Selection.Interior.ColorIndex = 15

Loop

End If

[xladept]

Maybe:

If rst.RecordCount > 1000 Then

ApXL.ActiveCell.Range("A2:C" & 1000).Interior.ColorIndex = 15

Do Until IsEmpty(ApXL.ActiveCell.Offset(1, 0))

For i = 0 To 999
If Cells(ActiveCell.row + i) = "" Then
ApXL.ActiveCell.Range("A1:C1").Offset(i+1, 0).Select
ApXL.Selection.Interior.ColorIndex = 2: Exit Do: End If

ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).Select
ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).Select
ApXL.Selection.Resize(1000, 1).Select
ApXL.Selection.Interior.ColorIndex = 2

For i = 0 To 999
If Cells(ActiveCell.row + i) = "" Then
ApXL.ActiveCell.Range("A1:C1").Offset(i+1, 0).Select
ApXL.Selection.Interior.ColorIndex = 15: Exit Do: End If

ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).Select
ApXL.Selection.Resize(1000, 1).Select
ApXL.Selection.Interior.ColorIndex = 15

Loop

End If

[Flower76]

This looks promising thanks! Although I'm getting a "Compile error: Loop without Do"

Any thoughts?

[xladept]

Hi Flower,

I forgot to write Next for the For Loops:

Sub Flower(): Dim i As Integer
If rst.RecordCount > 1000 Then

ApXL.ActiveCell.Range("A2:C" & 1000).Interior.ColorIndex = 15

Do Until IsEmpty(ApXL.ActiveCell.Offset(1, 0))

For i = 0 To 999
If Cells(ActiveCell.row + i) = "" Then
ApXL.ActiveCell.Range("A1:C1").Offset(i, 0).Select
ApXL.Selection.Interior.ColorIndex = 2: Exit Do: End If
Next i
ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).Select
ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).Select
ApXL.Selection.Resize(1000, 1).Select
ApXL.Selection.Interior.ColorIndex = 2

For i = 0 To 999
If Cells(ActiveCell.row + i) = "" Then
ApXL.ActiveCell.Range("A1:C1").Offset(i, 0).Select
ApXL.Selection.Interior.ColorIndex = 15: Exit Do: End If
Next i
ApXL.ActiveCell.Range("A1:C1").Offset(1000, 0).Select
ApXL.Selection.Resize(1000, 1).Select
ApXL.Selection.Interior.ColorIndex = 15

Loop

End If
End Sub

[Flower76]

That seems to solve the compile error but unfortunately the output isn't right. I'm working just in an excel sheet right now rather than from access just to make it easier to get things working. I put different colors and lowered it to blocks of 10 just to see what's happening. It seems to highlight the first 10 as it should but then it highlights line 4 with colourindex 7? And then nothing else happens.

This is the code as it stands now:



Dim i As Integer

Range("A1:C1").Select

Do Until IsEmpty(ActiveCell.Offset(1, 0))
ActiveCell.Range("A2:C" & 10).Interior.ColorIndex = 15

For i = 0 To 9
If Cells(ActiveCell.Row + i) = "" Then
ActiveCell.Range("A1:C1").Offset(i, 0).Select
Selection.Interior.ColorIndex = 7: Exit Do: End If
Next i
ActiveCell.Range("A1:C1").Offset(10, 0).Select
Selection.Resize(1000, 1).Select
Selection.Interior.ColorIndex = 6

For i = 0 To 9
If Cells(ActiveCell.Row + i) = "" Then
ActiveCell.Range("A1:C1").Offset(i, 0).Select
Selection.Interior.ColorIndex = 12: Exit Do: End If
Next i
ActiveCell.Range("A1:C1").Offset(10, 0).Select
Selection.Resize(10, 1).Select
Selection.Interior.ColorIndex = 16

Loop

[xladept]

Selection.Resize(1000, 1).Select

???

[Flower76]

I forgot to change that one to 10 as well Still doesn't change the output though

I don't think it likes the first if statement (below) as it highlights in that color no matter if it is filled or not. And it's filled so it shouldn't be highlighting in that color. It's also not looping so must be exiting.

If Cells(ActiveCell.Row + i) = "" Then

[xladept]

Hi Flower,

Maybe:

Sub Flower(): Dim i As Integer
Dim i As Integer

Range("A1:C1").Select

Do Until IsEmpty(ActiveCell.Offset(1, 0))
ActiveCell.Range("A2:C" & 10).Interior.ColorIndex = 15
ActiveCell.Offset(10, 0).Select
For i = 0 To 9
If Cells(ActiveCell.row + i) = "" Then
ActiveCell.Range("A1:C1").Offset(i, 0).Select
Selection.Interior.ColorIndex = 7: Exit Do: End If
Next i
ActiveCell.Range("A1:C1").Offset(10, 0).Select
Selection.Resize(10, 3).Select
Selection.Interior.ColorIndex = 6
ActiveCell.Offset(10, 0).Select

For i = 0 To 9
If Cells(ActiveCell.row + i) = "" Then
ActiveCell.Range("A1:C1").Offset(i, 0).Select
Selection.Interior.ColorIndex = 12: Exit Do: End If
Next i
ActiveCell.Range("A1:C1").Offset(10, 0).Select
Selection.Resize(10, 3).Select
Selection.Interior.ColorIndex = 16
ActiveCell.Offset(10, 0).Select
Loop
 
End Sub

[Flower76]

Ultimately I reworked it and used countA which seemed to work for me. Here is my final code. Thanks for the help!

Dim i As Integer

Range("A1:C1").Select


ActiveCell.Range("A1:C1").Offset(1, 0).Select
Selection.Resize(2000, 1).Select

Do Until (Application.WorksheetFunction.CountA(Selection)) = 0

    If (Application.WorksheetFunction.CountA(Selection)) = 2000 Then
        i = (Application.WorksheetFunction.CountA(Selection))
        Selection.Resize(1000, 3).Select
        Selection.Interior.ColorIndex = 15
        ActiveCell.Range("A1:C1").Offset(1000, 0).Select
        Selection.Resize(1000, 3).Select
        Selection.Interior.ColorIndex = 35
    End If

        If (Application.WorksheetFunction.CountA(Selection)) > 1000 And (Application.WorksheetFunction.CountA(Selection)) < 2000 Then
        Selection.Resize(1000, 3).Select
        Selection.Interior.ColorIndex = 15
        ActiveCell.Range("A1:C1").Offset(1000, 0).Select
        Selection.Resize(1000, 1).Select
        i = (Application.WorksheetFunction.CountA(Selection))
        Selection.Resize(i, 3).Select
        Selection.Interior.ColorIndex = 35: Exit Do: End If

        If (Application.WorksheetFunction.CountA(Selection)) <= 1000 Then
        i = (Application.WorksheetFunction.CountA(Selection))
        Selection.Resize(i, 3).Select
        Selection.Interior.ColorIndex = 15: Exit Do: End If


ActiveCell.Range("A1:C1").Offset(1000, 0).Select
Selection.Resize(2000, 1).Select

Loop

Range("A1").Select

[xladept]

You're welcome!