select used range, but exclude the highlighted rows

teekayy

New Member
Joined
Feb 7, 2012
Messages
32
Hi All,

Loving everyones work on here - I have learnt so much!

I was hoping to receive some help for the following:

I have a macro which implements an advanced filter on a range. The next step that i need is to only select the cells which are NOT highlighted in yellow from what the filter has returned. This filtered data (with highlighted rows omitted) needs to then be copied and pasted to a new workbook.

This is my code so far:

Code:
Sub Select_data()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.AutoFilterMode = False

If ActiveSheet.FilterMode = True Then
ActiveSheet.ShowAllData

Range("A1:AU1000000").AdvancedFilter Action:=xlFilterInPlace, _
CriteriaRange:=Sheets(1).Range("B1:B100"), Unique:=False


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

Gratefull for any assitance!

Thanks
 

Some videos you may like

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,406
It looks like you're using Excel 2007 or later version. If so, it may be more efficient to use the AutoFilter, instead of the AdvancedFilter. The AutoFilter will allow you to filter for an array of values, and it will also allow you to filter by cell color. Otherwise, your code could be amended as follows...

Code:
[FONT=Courier New][COLOR=darkblue]Option[/COLOR] [COLOR=darkblue]Explicit[/COLOR]

[COLOR=darkblue]Sub[/COLOR] Select_data()


    [COLOR=darkblue]Dim[/COLOR] VisRng [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] CopyRng [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] Cell [COLOR=darkblue]As[/COLOR] Range
    
    [COLOR=darkblue]With[/COLOR] Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] ActiveSheet
        .AutoFilterMode = [COLOR=darkblue]False[/COLOR]
        [COLOR=darkblue]If[/COLOR] .FilterMode = [COLOR=darkblue]True[/COLOR] [COLOR=darkblue]Then[/COLOR] .ShowAllData
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] ActiveSheet.UsedRange
        .AdvancedFilter Action:=xlFilterInPlace, _
            CriteriaRange:=Sheets(1).Range("B1:B100"), Unique:=[COLOR=darkblue]False[/COLOR]
        [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]Resume[/COLOR] [COLOR=darkblue]Next[/COLOR]
        [COLOR=darkblue]Set[/COLOR] VisRng = .Resize(.Rows.Count - 1, 1).Offset(1, 0).SpecialCells(12)
        [COLOR=darkblue]On[/COLOR] [COLOR=darkblue]Error[/COLOR] [COLOR=darkblue]GoTo[/COLOR] 0
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] VisRng [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
        [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] Cell [COLOR=darkblue]In[/COLOR] VisRng
            [COLOR=darkblue]If[/COLOR] Cell.Interior.ColorIndex = -4142 [COLOR=darkblue]Then[/COLOR]
                [COLOR=darkblue]If[/COLOR] CopyRng [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
                    [COLOR=darkblue]Set[/COLOR] CopyRng = Cell
                [COLOR=darkblue]Else[/COLOR]
                    [COLOR=darkblue]Set[/COLOR] CopyRng = Union(Cell, CopyRng)
                [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
            [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
        [COLOR=darkblue]Next[/COLOR] Cell
        [COLOR=darkblue]If[/COLOR] [COLOR=darkblue]Not[/COLOR] CopyRng [COLOR=darkblue]Is[/COLOR] [COLOR=darkblue]Nothing[/COLOR] [COLOR=darkblue]Then[/COLOR]
            CopyRng.EntireRow.Copy Workbooks("Book2.xlsx").Sheets(1).Range("A2") [COLOR=green]'change the copy destination accordingly[/COLOR]
        [COLOR=darkblue]Else[/COLOR]
            MsgBox "No un-highlighted rows are available...", vbInformation
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    [COLOR=darkblue]Else[/COLOR]
        MsgBox "No records are available...", vbInformation
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]If[/COLOR]
    
    ActiveSheet.ShowAllData
    
    [COLOR=darkblue]With[/COLOR] Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]
[/FONT]

Note that any highlighted row will be excluded from being copied. If you want to exclude only rows highlighted in yellow, and not in any other color, replace...

Code:
[COLOR=darkblue][FONT=Courier New]If[/FONT][/COLOR][FONT=Courier New] Cell.Interior.ColorIndex = -4142 [/FONT][COLOR=darkblue][FONT=Courier New]Then[/FONT][/COLOR]

with

Code:
[COLOR=darkblue][FONT=Courier New]If[/FONT][/COLOR][FONT=Courier New] Cell.Interior.ColorIndex <> 6 [/FONT][COLOR=darkblue][FONT=Courier New]Then[/FONT][/COLOR]
 

teekayy

New Member
Joined
Feb 7, 2012
Messages
32
Thanks Domenic - you have improved my code immensely!

One question - i was stepping through the code and it doesn't appear as though the filter is being applied. Is this because the column that i want filtered isn't being specified (column E)?

Many thanks,

Tee
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,406
I'm assuming that B1 in Sheets(1).Range("B1:B100") contains the column label/header for the column you want to filter, correct? If not, make sure that you add the column label/header. If so, then it's likely that you have one or more empty cells in your criteria range. Try the following instead (changes are in red)...

Code:
Option Explicit

Sub Select_data()


    Dim VisRng As Range
    Dim CopyRng As Range
[COLOR=#ff0000]    Dim CritRng As Range[/COLOR]
    Dim Cell As Range
    
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    
    With ActiveSheet
        .AutoFilterMode = False
        If .FilterMode = True Then .ShowAllData
    End With
    
    [COLOR=#ff0000]With Sheets(1)
        Set CritRng = .Range("B1", .Cells(.Rows.Count, "B").End(xlUp))
    End With[/COLOR]
    
    With ActiveSheet.UsedRange
        .AdvancedFilter Action:=xlFilterInPlace, _
            CriteriaRange:=[COLOR=#ff0000]CritRng[/COLOR], Unique:=False
        On Error Resume Next
        Set VisRng = .Resize(.Rows.Count - 1, 1).Offset(1, [COLOR=#ff0000]4[/COLOR]).SpecialCells(12)
        On Error GoTo 0
    End With
    
    If Not VisRng Is Nothing Then
        For Each Cell In VisRng
            If Cell.Interior.ColorIndex = -4142 Then
                If CopyRng Is Nothing Then
                    Set CopyRng = Cell
                Else
                    Set CopyRng = Union(Cell, CopyRng)
                End If
            End If
        Next Cell
        If Not CopyRng Is Nothing Then
            CopyRng.EntireRow.Copy Workbooks("Book2.xlsx").Sheets(1).Range("A2")
        Else
            MsgBox "No un-highlighted rows are available...", vbInformation
        End If
    Else
        MsgBox "No records are available...", vbInformation
    End If
    
    ActiveSheet.ShowAllData
    
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    
End Sub
 

teekayy

New Member
Joined
Feb 7, 2012
Messages
32

ADVERTISEMENT

Great! The data is now being filtered :)

However - the code is producing a "Runtime error 9 - Subscript out of range" on the following line:

Code:
CopyRng.EntireRow.Copy Workbooks("Book4.xlsx").Sheets(1).Range("A1")

Any suggestions?

Thanks
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,406
That's probably because Book4.xlsx is not opened. Is this the case?
 

teekayy

New Member
Joined
Feb 7, 2012
Messages
32

ADVERTISEMENT

Hi Domenic - the corresponding workbook is opened
 

Domenic

MrExcel MVP
Joined
Mar 10, 2004
Messages
19,406
Is the name of the workbook spelled correctly? Is the file extension in fact .xlsx, and not .xlsm? Does the filename contain any extra spaces?
 

teekayy

New Member
Joined
Feb 7, 2012
Messages
32
Hi Domenic!

It seemed to work when I actually saved Book4 as opposed to just creating a new workbook with book4 as the name - thanks!

On this note, is it possible to paste the data into a new workbook instead of one that is already opened and saved?

Cheers for all your help :)
 

teekayy

New Member
Joined
Feb 7, 2012
Messages
32
never mind about the above! I was able to integrate with some simple code :)

Thanks again for all your help!

Very much appreciated!

Tee
 

Watch MrExcel Video

Forum statistics

Threads
1,122,498
Messages
5,596,509
Members
414,073
Latest member
Contilly

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top