select used range, but exclude the highlighted rows

[teekayy]

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:

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

 

[Domenic]

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

[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...

[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

[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]

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]

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

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]

Great! The data is now being filtered

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

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

Any suggestions?

Thanks

 

[Domenic]

That's probably because Book4.xlsx is not opened. Is this the case?

 

[teekayy]

Hi Domenic - the corresponding workbook is opened

 

[Domenic]

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]

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]

never mind about the above! I was able to integrate with some simple code

Thanks again for all your help!

Very much appreciated!

Tee