If I filter data in column 2, I wanted to change the filtered row/s background color. Is it possible?
My intention is, if there is any filter on the column then I want to show that differently.
please see pictures below of the results I wanted to achieve:
Choosing values to Filter in Column 2
On change Color on Filtered Rows(Yellow)
Rows will go back to Original state when there is no filter
Try the next code, please:
Sub TESTColorFilteredRange()
Dim sh As Worksheet, lastR As Long, rng As Range, rngF As Range
Dim filtCol As Long 'column to be filtered
Dim filterCriteria As String 'set here your filter criteria
filtCol = 1 'column A:A. Change here according to your need
filterCriteria = "A" 'Set it your criteria. I ued "A" for testing reason...
Set sh = ActiveSheet
sh.cells.AutoFilter 'clear te filter if it exists
lastR = sh.cells(Rows.count, filtCol).End(xlUp).Row 'last row on the column to be filtered
Set rng = sh.Range(sh.cells(1, filtCol), sh.cells(lastR, filtCol)) 'set the range to be filtered
rng.AutoFilter field:=1, Criteria1:="=" & filterCriteria 'filter the range
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set the filtered cells range
rngF.Interior.Color = vbYellow 'color the filtered range interior
NotIntersect(rng, rngF).Interior.Color = xlNone 'uncolor the not filtered range interior
End Sub
Function NotIntersect(rng As Range, rngF As Range) As Range 'determines the not filtered range
Dim rngNI As Range, i As Long
For i = 1 To rng.Rows.count
If rng.cells(i, 1).EntireRow.Hidden Then
If rngNI Is Nothing Then
Set rngNI = rng.cells(i, 1)
Else
Set rngNI = Union(rngNI, rng.cells(i, 1))
End If
End If
Next i
If Not rngNI Is Nothing Then Set NotIntersect = rngNI
End Function
Test it and send some feedback, please.
NotIntersect is necessary to clear the coloring on the not filtered range. Otherwise, after some tests using different criteria, all the range cells will be colored...
Related
In the below code i'm trying to use a for loop through a filtered list.
Without the offset the loop is going through each field and copying the data multiple times. With the offset its skipping rows.
How can I rephrase this to only loop through each row once, and skip the header row?
'Offset Placement Wrong
Set rngVisible = activeSheet.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Offset(1, 0)
For Each rngCell In rngVisible
Rows(rngCell.Row).Select
Selection.Copy
Sheets(2).Select
'Skip Headers
Cells(2 + rowsRelocated, 1).Select
activeSheet.Paste
Sheets(1).Select
'row increment
rowsRelocated = rowsRelocated + 1
Next
Restrict the range to one column of your filter.
Dim rngVisible As Range, RowsRelocated As Long, rngCell As Range
Set rngVisible = ActiveSheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible)
RowsRelocated = 0
For Each rngCell In rngVisible.Cells
If rngCell.Row > 1 Then
rngCell.EntireRow.Copy Sheets(2).Cells(2 + RowsRelocated, 1)
RowsRelocated = RowsRelocated + 1
End If
Next
You can copy all filtered visible data at once from Sheets(1) to Sheets(2)...
Sub test()
Dim allData As Range, FilteredData As Range, rngVisible As Range, TargetRange As Range
Set allData = Sheets(1).Range("A1").CurrentRegion
'Instead of currentregion you could mention actual range if it contains blank rows.
Set FilteredData = allData.Offset(1, 0).Resize(allData.Rows.Count - 1, allData.Columns.Count)
Set rngVisible = FilteredData.Cells.SpecialCells(xlCellTypeVisible)
Set TargetRange = Sheets(2).Range("A1").CurrentRegion.Offset(Sheets(2).Range("A1").CurrentRegion.Rows.Count, 0)
'Assuming that Row 1 in Sheets(2) is header, Copy visible data from A2
rngVisible.Copy TargetRange
End Sub
I have a cell designated as a Search Box for user entry (called 'UserSearch') and need to be able to use this input to filter multiple columns at the same time. For example, if the user searched for 'Apple', I need the VBA code to filter out all rows where that word appears, even if it appeared in another column. I am currently stuck on only being able to filter out one column at a time but this input may also appear in another column but the row won't be filtered because it may have gotten filtered out by the column before it.
My current code is below is:
Sub search()
With ActiveSheet.Range("$a$4:$j$30")
.AutoFilter Field:=1, Criteria1:="=*" & Range("UserSearch") & "*", Operator:=xlOr
.AutoFilter Field:=2, Criteria1:="=*" & Range("UserSearch") & "*", Operator:=xlOr
.AutoFilter Field:=3, Criteria1:="=*" & Range("UserSearch") & "*"
End With
End Sub
As you can see, my goal is to be able to run autofilter on all 3 fields simultaneously (essentially treating the 3 columns as just one) but the code above contradicts each other and no rows are returned. Anyone have any idea by using autofilter?
You cannot use .AutoFilter for this but yes using a small vba code you can achieve what you want
Let's say your worksheet looks like this
Paste this code in a module
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngHide As Range
Dim FoundIt As Long, i As Long, lRow As Long
Dim SearchString As String
'~~> Your search string
SearchString = "Apple"
'~~> Change this to the relevant sheet
Set ws = Sheet1
'~~> Find the last row
' https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
'~~> Loop through 4 to last row to find the search string
For i = 4 To lRow
On Error Resume Next
FoundIt = Application.WorksheetFunction.Match(SearchString, ws.Rows(i), 0)
On Error GoTo 0
'~~> Create a range which needs to be hidden
If FoundIt = 0 Then
If rngHide Is Nothing Then
Set rngHide = ws.Rows(i)
Else
Set rngHide = Union(rngHide, ws.Rows(i))
End If
End If
FoundIt = 0
Next i
'~~> Hide it if applicable
If Not rngHide Is Nothing Then rngHide.EntireRow.Hidden = True
End Sub
I have commented the code so you should not have a problem understanding it. but if you do then simply ask.
In Action
These two macros are more basic, but accomplish the same task as Sid's answer...
The first macro loops through the range and checks the first three cells in the current row for the search text, if found in any of the cells, it will loop to the next row. If no cells contain the search text, the row will be hidden
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Define your worksheet
Dim UserSearch As String: UserSearch = ws.Range("A2").Value 'Assign the range for the user entry, change as needed
For Each cel In ws.Range("A4", ws.Cells(ws.Rows.Count, 1).End(xlUp)) 'Loop through the range
'Using (= and Or) test if any of the first three cells in the current row contain the search text
If cel.Value = UserSearch Or cel.Offset(, 1).Value = UserSearch Or cel.Offset(, 2).Value = UserSearch Then
'If the search text is found in any of the cells then loop to the next row
Else
'If the search text is not in any of the cells then hide the row
cel.EntireRow.Hidden = True
End If
Next cel
The second macro loops through the range and checks the first three cells in the current row for the search text, if not found, the row will be hidden
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Define your worksheet
Dim UserSearch As String: UserSearch = ws.Range("A2").Value 'Assign the range for the user entry, change the range as needed
For Each cel In ws.Range("A4", ws.Cells(ws.Rows.Count, 1).End(xlUp)) 'Loop through the range
'Using (<> and And) test the first three cells in the current row
If cel.Value <> UserSearch And cel.Offset(, 1).Value <> UserSearch And cel.Offset(, 2).Value <> UserSearch Then
'If the search text is not found hide the current row
cel.EntireRow.Hidden = True
End If
Next cel
I am trying to transfer two rows of Sheet1 (randomly and based on certain criteria) into Sheet3.
The values in cells "P2" and "P5" indicate the row number to be transferred, and column "A" has row numbers.
There's no possibility that values in "P2" and "P5" could match multiple rows in column "A". They should match 1 row each, so only one row should be copied per "P2" and "P5". Yet, sometimes I see multiple rows getting copied.
Below is the code:
Sub copyrows()
Dim tfRow As Range, cell As Object
Set tfRow = Range("A1:A") 'Range which includes the values
For Each cell In tfRow
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P2").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Sub copyrows2()
Dim tfRow2 As Range, cell As Object
Set tfRow2 = Range("A1:A") 'Range which includes the values
For Each cell In tfRow2
If IsEmpty(cell) Then
Exit Sub
End If
If cell.Value = Range("P5").Value Then
cell.EntireRow.Copy
Sheet3.Select 'Target sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
As #urdearboy mentioned in the commnets above, you need to add a row to your second A column range to avoid getting the error.
To merge two conditions, in your case add an Or to your If.
To run the code faster, don't Select and Activate different sheets, it takes a long time for the code to run. Instead, use a Range object, like CopyRng and every time the if criteria is ok, you add that cell to the range using the Union function.
Read HERE about the Union functionality.
More comments inside the code's notes below.
Modified Code
Option Explicit
Sub copyrows()
Dim Sht1 As Worksheet, Sht3 As Worksheet
Dim tfRow As Range, C As Range ' use Range not Object, also try not to use Cell it's close to Cells
Dim CopyRng As Range
Dim LastRow As Long
Set Sht1 = Sheet1
Set Sht3 = Sheet3
With Sht1
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column A
Set tfRow = .Range("A1:A" & LastRow) 'Range which includes the values
For Each C In tfRow
If IsEmpty(C) Then
Exit Sub
End If
If C.Value = .Range("P2").Value Or C.Value = .Range("P5").Value Then ' use Or to combine both scenarios
If Not CopyRng Is Nothing Then
Set CopyRng = Application.Union(CopyRng, C) ' use Union to merge multiple ranges
Else
Set CopyRng = C
End If
End If
Next C
End With
' make sure there is at least one cells in your merged range
If Not CopyRng Is Nothing Then
' get last row with data in "sheet3"
LastRow = Sht3.Cells(Sht3.Rows.Count, "A").End(xlUp).Row
CopyRng.EntireRow.Copy Destination:=Sht3.Range("A" & LastRow + 1)
End If
End Sub
I am trying to get a filtered range into an array, on my test data the array fArr has the proper dim and fLR is the proper count of the filter range
But filRange is always only the header range NOT the filtered range
How to get filRange to be the filtered range?
Or to the point how to get fArr to be an array of the filter data?
Thanks
Sub arrFilterdRng()
Dim fArr As Variant
Dim rRange As Range, filRange As Range, myCell As Range
Dim fLR As Long, rCtr As Long
'Remove any filters
ActiveSheet.AutoFilterMode = False
'~~> Set your range
Set rRange = Sheets("Z").UsedRange
With rRange
'~~> Set your criteria and filter
.AutoFilter Field:=3, Criteria1:="*"
Set filRange = .SpecialCells(xlCellTypeVisible).EntireRow
fLR = .Resize(, 1).SpecialCells(xlCellTypeVisible).Count
Debug.Print fLR
ReDim fArr(1 To fLR, 1 To .Columns.Count)
Debug.Print UBound(fArr, 1), UBound(fArr, 2)
rCtr = 0
For Each myCell In filRange.Columns(1)
rCtr = rCtr + 1
For cCtr = 1 To .Columns.Count
fArr(rCtr, cCtr) = myCell.Offset(0, cCtr - 1).value
Next cCtr
Next myCell
End With
'Remove any filters
ActiveSheet.AutoFilterMode = False
End Sub
My data looks like this (all text)
My feeling is that the wildcard in your criteria is causing the trouble.
"*" only works for strings, so if your data are numbers (including dates) then they would be removed by the filter (ie they wouldn't be visible), so you would indeed only have the header in your range.
If you want numerical values, then one way of doing it would be to define a value, say:
.AutoFilter Field:=3, Criteria1:=">0"
or, if you want limits:
.AutoFilter Field:=3, Criteria1:=">0", Operator:=xlAnd, Criteria2:="<10"
If, on the other hand, you just want anything but blank cells, then the syntax should be:
.AutoFilter Field:=3, Criteria1:="<>"
You should also be aware that if the filtered range contains non-contiguous ranges, then each 'separate' range would be contained within the Areas collection. This means something like filRange.Rows.Count would only return the row count of the first area; and you can get real difficulties when you try to Offset and/or Resize the filtered range. It's also not possible to directly read non-contiguous ranges into an array using the .Value property.
I'm not sure your code is the most efficient way of handling your task, but keeping the same structure it could look like this:
Dim rRange As Range, filRange As Range
Dim myArea As Range, myRow As Range, myCell As Range
Dim fArr() As Variant
Dim r As Long
With ThisWorkbook.Worksheets("Z")
.AutoFilterMode = False
Set rRange = .UsedRange
End With
With rRange
.AutoFilter Field:=3, Criteria1:=">0"
Set filRange = .SpecialCells(xlCellTypeVisible)
End With
With filRange
r = -1 'start at -1 to remove heading row
For Each myArea In filRange.Areas
r = r + myArea.Rows.Count
Next
ReDim fArr(1 To r, 1 To .Columns.Count)
End With
r = 1
For Each myArea In filRange.Areas
For Each myRow In myArea.Rows
If myRow.Row <> 1 Then
For Each myCell In myRow.Cells
fArr(r, myCell.Column) = myCell.Value
Next
r = r + 1
End If
Next
Next
Perhaps your data has more complexity, but you can simply assign the values of a range to an array with:
var = rng.SpecialCells(xlCellTypeVisible).Value
Thus no need to loop over the data.
Here's a working example with this simple grid of data:
This code:
Option Explicit
Sub arrFilterdRng()
Dim ws As Worksheet '<-- your worksheet
Dim rng As Range '<-- your range to filter
Dim var As Variant '<-- will hold array of visible data
Dim lng1 As Long, lng2 As Long
' get sheet; remove filters
Set ws = ThisWorkbook.Worksheets("Sheet2")
ws.AutoFilterMode = False
' get range; apply filter
Set rng = ws.UsedRange
rng.AutoFilter Field:=1, Criteria1:="x"
' assign visible range to array
var = rng.SpecialCells(xlCellTypeVisible).Value
' test array
For lng1 = LBound(var, 1) To UBound(var, 1)
For lng2 = LBound(var, 2) To UBound(var, 2)
Debug.Print var(lng1, lng2)
Next lng2
Next lng1
End Sub
Results in this on the sheet:
And the output to the Immediate window for the content of var is:
a
b
c
x
2
3
x
5
6
I need to copy data from one worksheet into another. However, I need a conditional copy operation that will skip rows based on criteria.
For example, if I start with...
Active Value
yes 1
no 2
no 3
yes 4
no 5
no 6
I only want to copy rows that are Active=yes, so I would end up with...
Value
1
4
Can someone show me how this is done with 1) a macro and 2) a formula?
Formula approach:
suppose your data are in sheet1, range A2:B7.
Then use this formula in sheet2 cell A2:
=IFERROR(INDEX(Sheet1!B:B,SMALL(IF(Sheet1!$A$2:$A$7="yes",ROW(Sheet1!$A$2:$A$7)),ROW()-ROW($A$2)+1)),"")
with array entry (CTRL+SHIFT+ENTER) and then drag it down.
VBA approach:
You can use AutoFilter:
Sub test()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim rng As Range, rngToCopy As Range
Dim lastrow As Long
'change Sheet1 and Sheet2 to suit
Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")
With ws1
'assumung that your data stored in column A:B, Sheet1
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A1:B" & lastrow)
'clear all filters
.AutoFilterMode = False
With rng
'apply filter
.AutoFilter Field:=1, Criteria1:="yes"
On Error Resume Next
'get only visible rows
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
'copy range
If Not rngToCopy Is Nothing Then rngToCopy.Copy Destination:=ws2.Range("A1")
'clear all filters
.AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Note, if you want to copy only Value column, change
Set rngToCopy = .SpecialCells(xlCellTypeVisible)
to
Set rngToCopy = .Offset(, 1).Resize(, .Columns.Count - 1).SpecialCells(xlCellTypeVisible)
It's easy enough with a macro. Assuming you're copying from the first sheet to the second sheet, and that your sample above is in columns A and B, you could do the following:
Public Sub ConditionalCopy()
Dim copyRng As Range
Set copyRng = Worksheets(1).Range("B2:B7")
Dim pasteRng As Range
Set pasteRng = Worksheets(2).Range("A2")
Dim i As Long
i = 0
For Each cell in copyRng.Cells
If cell.Offset(0, -1).Value2 = "yes" Then
pasteRng.Offset(i,0).Value2 = cell.Value2
i = i + 1
End If
Next cell
End Sub
Doing it with a formula presents a challenge in terms of not leaving any blank rows on the second sheet. It would be pretty trivial to just use the following in the second sheet:
=If(A2 = "yes",b2,"")
And copy that down, but you're going to end up with blank rows that you'll have to go back and delete yourself. If you have the ability to use the macro, it's straightforward enough that I would go that route rather than sinking too much effort into devising a formula. The more I think about it, the more I feel like it has to be a programmatic solution to avoid double references.
If you use seperate counters for the source and destination rows, and use cell references rather than ranges the following routine should do the trick
Public Sub copyactivevalue()
Dim i As Integer
Dim j As Integer
Dim acts As Excel.Worksheet
Dim news As Excel.Worksheet
Set acts = Excel.Worksheets("sheet1")
Set news = Excel.Worksheets("sheet2")
With acts
j = 2
For i = 2 To 7
If acts.Cells(i, 1).Value = "yes" Then
news.Cells(j, 1) = acts.Cells(i, 2).Value
j = j + 1
End If
Next
End With
Set acts = Nothing
Set news = Nothing
End Sub
Hope this helps