Get a filtered range into an array - excel

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

Related

Alternatives to ActiveSheet.Paste to reduce memory

I am trying to utilise the VBA/macro function at work. However, I came across a problem which says something like 'error; insufficient memory' and after some browsing on the internet I realise that copy and pasting generally takes up a lot of spaces in the Excel and my Excel in workplace is only 32 bits. Therefore, does anyone know any good alternatives to ActiveSheet.Paste?
My codes are currently as following:
ActiveSheet.Range ("$A$!:$Y$1000").AutoFilter Field:=7, Criterial:=_banker
Range("A1").Select
Range(Selection, Selection.End(x1Down)).Select
Range(Selection, Selection.End(X1ToRight)).Select
Selection.Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
ActiveSheet.Name= banker
i=i+1
Loop
End Sub
You should copy your code as it is and no writing it. In this way you will avoid spelling mistakes (Range ("$A$!:$Y$1000") instead of "A1:..., X1ToRight instead of XlToRight, "_banker" instead of "banker"). Putting Option Explicit on top of your module, as recommended above will help.
A way to filter and copy the filter range, not involving the clipboard should be the next code. Please, test it and send some feedback:
Sub testFilterCopyRange()
Dim sh As Worksheet, shNew As Worksheet, lastR As Long
Dim banker As String, rng As Range, rngF As Range, arr, i As Long
Dim maxIt As Long 'number of iterations
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row 'last row
maxIt = 1 'set here the maximum number of necessary iterations
sh.AutoFilterMode = False 'eliminate the previous filter
Set rng = sh.Range("A1:H" & lastR) 'set the range to be processed
For i = 1 To maxIt
banker = "7" '"your dinamic criteria"
rng.AutoFilter field:=7, Criteria1:=banker 'filter the range according to above defined criteria
Set rngF = rng.SpecialCells(xlCellTypeVisible) 'set a range to keep the filtered cells in the range
arr = arrayFromDiscRange(rngF, False) 'header inclusive
Set shNew = Sheets.Add(After:=sh): shNew.Name = banker 'add a new sheet and name it
shNew.Range("A1").Resize(UBound(arr), UBound(arr, 2)).value = arr 'drop the array content at once
Next i
End Sub
'function able to transform a filtered (discontinue) range in an array:
Private Function arrayFromDiscRange(rngF As Range, Optional NoHeader As Boolean = False) As Variant
Dim arr, i As Long, j As Long, k As Long, A As Range, R As Range, iRows As Long
'count range rows
For Each A In rngF.Areas
iRows = iRows + A.rows.count
Next A
'Redim the array to keep the range
ReDim arr(1 To iRows - IIf(NoHeader, 1, 0), 1 To rngF.Columns.count): k = 1
For Each A In rngF.Areas 'iterate between the range areas:
For Each R In A.rows 'iterate between the area rows:
If NoHeader And k = 1 Then GoTo Later 'skip the first row, if no header wanted
For j = 1 To R.Columns.count 'iterate between the area row columns:
arr(k, j) = R.cells(1, j).value 'place each row cells value in the array row
Next j
k = k + 1 'intrement the array row to receive values
Later:
Next
Next A
arrayFromDiscRange = arr 'returning the created array
End Function
If something unclear, even if I tried commenting all the code line which could be problematic in understanding, please do not hesitate to ask for clarifications.

Excel VBA Hidding rows by comparing two Cells

I have a question about how to use a double loop to compare two Cells which are located in different sheets("Sheet1" and "Sheet2").
The condition I want to apply to the Loop is that in case if the two cells are different, the row must be hidden (Applied to the table located in Sheet1). In the contrary case, if the two cells are the same, the row stays as it is by default.
But with the Macro I wrote, it hides all rows that form the Sheet1 table. What could be the reason?
Sub HideRows()
Sheets("Sheet2").Select
Dim NR As Integer
NR = WorksheetFunction.CountA(Range("A1", Range("A1").End(xlDown)))
Sheets("Sheet1").Select
Dim i As Integer, j As Integer
For i = 2 To 10
For j = 1 To NR
If Cells(i, 1) <> Sheets("Sheet2").Cells(j, 1) Then
Rows(i & ":" & i).Select
Selection.EntireRow.Hidden = True
End If
Next j
Next I
End Sub
Sheet1:
Sheet2:
Desired result:
Your task is better described as
Hide all rows on Sheet1 whose column A value does not apear on Sheet2 column A
Using the looping the ranges technique you tried, this could be written as
Sub HideRows()
Dim rng1 As Range, cl1 As Range
Dim rng2 As Range, cl2 As Range
Dim HideRow As Boolean
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
rng1.EntireRow.Hidden = False
For Each cl1 In rng1.Cells
HideRow = True
For Each cl2 In rng2.Cells
If cl1.Value2 = cl2.Value2 Then
HideRow = False
Exit For
End If
Next
If HideRow Then
cl1.EntireRow.Hidden = True
End If
Next
End Sub
That said, while this approach is ok for small data sets, it will be slow for larger data sets.
A better approach is to loop Variant Arrays of the data, and build a range reference to allow hiding all required rows in one go
Sub HideRows2()
Dim rng1 As Range, cl1 As Range, dat1 As Variant
Dim rng2 As Range, cl2 As Range, dat2 As Variant
Dim HideRow As Boolean
Dim r1 As Long, r2 As Long
Dim HideRange As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat1 = rng1.Value2
End With
With ThisWorkbook.Worksheets("Sheet2")
Set rng2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
dat2 = rng2.Value2
End With
rng1.EntireRow.Hidden = False
For r1 = 2 To UBound(dat1, 1)
HideRow = True
For r2 = 1 To UBound(dat2, 1)
If dat1(r1, 1) = dat2(r2, 1) Then
HideRow = False
Exit For
End If
Next
If HideRow Then
If HideRange Is Nothing Then
Set HideRange = rng1.Cells(r1, 1)
Else
Set HideRange = Application.Union(HideRange, rng1.Cells(r1, 1))
End If
End If
Next
If Not HideRange Is Nothing Then
HideRange.EntireRow.Hidden = True
End If
End Sub
#Chjris Neilsen has beaten me to most of what I wanted to mention. Please refer to his comment above. However, there are two things I want to add.
Please don't Select anything. VBA knows where everything is in your workbook. You don't need to touch. Just point.
i and j aren't really meaningful variable identifiers for Rows and Columns. They just make your task that much more difficult - as if you weren't struggling with the matter without the such extra hurdles.
With that out of the way, your code would look as shown below. The only real difference is the Exit For which ends the loop when the decision is made to hide a row. No guarantee that the procedure will now do what you want but the logic is laid are and shouldn't be hard to adjust. I point to .Rows(C).Hidden = True in this regard. C is not a row. It's a column.
Sub HideRows()
' always prefer Long datatype for rows and columns
Dim Rl As Long ' last row: Sheet2
Dim C As Long ' loop counter: columns
Dim R As Long ' loop counter: rows
Rl = WorksheetFunction.CountA(Sheet2.Columns(1))
With Sheet1
For C = 2 To 10
For R = 1 To Rl
' always list the variable item first
If Sheets("Sheet2").Cells(R, 1).Value <> .Cells(C, 1).Value Then
.Rows(C).Hidden = True
Exit For
End If
Next R
Next C
End With
End Sub

Change filtered cell background color for that filtered values in a column

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

Correct way to offset headers while looping through a filtered list?

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

Faster code for cuting 'good row range' from sh2 to sh1?

Does it exist any way to make this code run faster as it goes one row by one row ?
Sub cut_good_row_range_from_sh2_to_sh1()
Application.ScreenUpdating = False
For i = 2 To Sheets("sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row
'Caution: I want to cut BB:BD, so I select BA:BD !
If Sheets("sheet1").Range("A" & i).Value = Sheets("sheet2").Range("A" & j).Value Then
Sheets("sheet2").Range("BA" & j & ":BS" & j).Cut Sheets("sheet1").Range("BA" & i & ":BS" & i)
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Thanks ;)
It has been demonstrated on SO many times that looping over ranges is slow, and looping over variant arrays is much faster.
The 'best' method depends on the specifics of the use case. Making as few assumptions as I can, this demo shows how effective it can be. The assumptions made are
Data only is required, Format is not transfered.
No Formulas exist in the Destination range (If they do, they will be overwritten with their current value)
This is a simplistic example, further optimisations can be made.
Sub Demo()
Dim Found As Boolean
Dim i As Long, j As Long, k As Long
Dim rSrcA As Range, rSrc As Range
Dim vSrcA As Variant, vSrc As Variant
Dim rDstA As Range, rDst As Range
Dim vDstA As Variant, vDst As Variant
Dim rClear As Range
' Get references to Source Data Range and Variant Array
With Worksheets("Sheet2")
Set rSrcA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
vSrcA = rSrcA.Value
Set rSrc = .Range("BA1:BS1").Resize(UBound(vSrcA, 1))
vSrc = rSrc
End With
' Get references to Destination Data Range and Variant Array
With Worksheets("Sheet1")
Set rDstA = Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
vDstA = rDstA.Value
Set rDst = .Range("BA1:BS1").Resize(UBound(vDstA, 1))
vDst = rDst
End With
' Loop Source
For i = 1 To UBound(vSrcA, 1)
' Loop Destination
For j = 1 To UBound(vDstA, 1)
' Compare
If vSrcA(i, 1) = vDstA(j, 1) Then
Found = True
' Update Destination Data Array, to be copied back to sheet later
For k = 1 To UBound(vSrc, 2)
vDst(j, k) = vSrc(i, k)
Next
End If
Next
' If match found, track Source range to clear later
If Found Then
If rClear Is Nothing Then
Set rClear = rSrc.Rows(i)
Else
Set rClear = Union(rClear, rSrc.Rows(i))
End If
Found = False
End If
Next
' Update Destination Range
rDst.Value = vDst
' Clear Source Range
rClear.ClearContents
End Sub
When run on a test data set of 15 source rows and 200 destination rows, this reduced execution time from about 17s to about 10ms

Resources