Selecting the first visible cell in a filtered column [duplicate] - excel

I am trying to select the first visible cell directly beneath the header of a filtered column. The code I am getting is as below, but I have to problems with this code. First, the first line of code is using the current active range of the file. It is highly likely that this file will change and this range will not be the same. How can I make it work for any file I would use it on? Second, if I use a totally different file with the same column format, the first visible cell under Column J could be J210. How can I make this work for any array of variables?
Sub Macro16()
'
' Macro16 Macro
'
'
ActiveSheet.Range("$A$1:$R$58418").AutoFilter Field:=12, Criteria1:= _
"Sheets"
Range("J2").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[1],3)"
Selection.FillDown
End Sub

Sub FirstVisibleCell()
With Worksheets("You Sheet Name").AutoFilter.Range
Range("A" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Select
End With
End Sub

Untested but:
Sub Macro16()
With ActiveSheet.Range("A1").CurrentRegion
.AutoFilter field:=12, Criteria1:="Sheets"
If .Columns(1).SpecialCells(xlCellTypeVisible).count > 1 Then
With .Columns(10)
.Resize(.rows.count - 1).offset(1).SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End With
End If
End With
End Sub

I prefer non-destructive methods of determining whether there are visible cells to work with after a filtering operation. Since you are filling in column J with a formula, there is no guarantee that column J contains any values tat can be counted with the worksheet's SUBTOTAL function (SUBTOTAL does not count rows hidden by a filter) but the formula you are planning to populate into column J references column K so there must be something there.
Sub Macro16()
With ActiveSheet
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, 1).CurrentRegion
.Columns(12).AutoFilter Field:=1, Criteria1:="Sheets"
With .Resize(.Rows.Count - 1, 1).Offset(1, 9)
If CBool(Application.Subtotal(103, .Offset(0, 1))) Then
.SpecialCells(xlCellTypeVisible).FormulaR1C1 = "=RIGHT(RC[1],3)"
End If
End With
.Columns(12).AutoFilter Field:=1
End With
End With
End Sub
      

Something like this might work...
Sub Macro16()
Dim ARow As Long, JRow As Long, ws1 As Worksheet
ws1 = Sheets("NAME OF SHEET WITH DATA")
ARow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("$A$1:$R$" & ARow).AutoFilter Field:=12, Criteria1:="Sheets"
JRow = ws1.Range("J" & ws1.Rows.Count).End(xlUp).Row + 1
ws1.Range("J" & JRow).FormulaR1C1 = "=RIGHT(RC[1],3)"
ws1.Range("J" & JRow).FillDown
End Sub

Related

VBA - Group with subgroup extract using keyword

Have data on columnA and trying to filter data using keywords. member of groups is in the down adjacent cells. starting with +.
Sub Mymacro()
Range("B2:B2000").Clear
For Each Cell In Sheets(1).Range("A1:A2000")
matchrow = Cell.Row
Find = "*" + Worksheets("Sheet1").Range("B1") + "*"
If Cell.Value Like Find Then
Cell.Offset(0, 1).Value = Cell.Offset(0, 0).Value
End If
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$1" Then
Call Mymacro
End If
End Sub
The above code is extracting text correctly with the green text but the expecting item is still missing which is just highlighted using the red text. tried a couple of options but no luck.
Referencing a worksheet with its index number as Sheets(1) is not advisable. It refers to the first sheet in the workbook including a chart sheet. If the sheet referred is moved from its first position in the workbook then the macro will run in the new worksheet at the first position. If the first sheet is a chart sheet, the macro will cause error. Hence, please replace below Sheets(1) reference with Sheet name like Sheets("Sheet1") or VBA Project worksheet name as Sheet1
Option Explicit
Sub Mymacro()
Dim fltArea As Range, fltAreas As Range, fltAreasGroup As Range
Dim lastRow As Long
lastRow = Sheets(1).Range("A1048576").End(xlUp).Row
Sheets(1).Range("B2:B" & lastRow).Clear
Sheets(1).Range("$A$1:$A$" & lastRow).AutoFilter Field:=1, Criteria1:="=+*", _
Operator:=xlAnd
Set fltAreasGroup = Sheets(1).Range("$A$2:$A$" & lastRow).SpecialCells(xlCellTypeVisible)
Sheets(1).AutoFilterMode = False
For Each fltAreas In fltAreasGroup.Areas
Set fltArea = fltAreas.Offset(-1).Resize(fltAreas.Rows.Count + 1, 1)
If InStr(1, Join(Application.Transpose(Application.Index(fltArea.Value, 0, 1)), ","), _
Sheets(1).Range("B1").Value, vbTextCompare) > 0 Then
fltArea.Offset(, 1).Value = fltArea.Value
End If
Next
Sheets(1).Range("$A$1:$B$" & lastRow).AutoFilter Field:=1, Criteria1:="=*" & Sheets(1).Range("B1").Value & "*", _
Operator:=xlAnd
Sheets(1).Range("$A$1:$B$" & lastRow).AutoFilter Field:=2, Criteria1:="="
Set fltAreas = Sheets(1).Range("$A$2:$A$" & lastRow).SpecialCells(xlCellTypeVisible)
Sheets(1).AutoFilterMode = False
For Each fltArea In fltAreas
fltArea.Offset(, 1).Value = fltArea.Value
Next
End Sub

VBA code - database Autofilter with cells in orther Sheet

i need your help on the VBA code :
i would like to make a filter on a database according cells in another sheets
my code is working but make a filter only in one cell. How to filter if the code found all cells from the Range
Please see my code :
Sub test()
Sheets("Dashboard").Select
Dim arr As Variant
'arr = Sheets("Dashboard").Range("B4:B11")
With Sheets("Database")
With .Range("A1:Z" & .Cells(.Rows.Count, "A").End(xlUp).Row)
.AutoFilter 'Turn off any previous filtering
.AutoFilter Field:=1, Criteria1:=Sheets("Dashboard").Range("B4:B11")
End With
End With
End Sub
Thanks for your help
Please, test the next way:
Sub filterByRange()
Dim arr, rng As Range
Set rng = Sheets("Dashboard").Range("B4:B11")
rng.TextToColumns Destination:=rng.cells(1), FieldInfo:=Array(1, 2)
arr = rng.Value
arr = Application.Transpose(Application.Index(arr, 0, 1)) '1D array
With Sheets("Database")
With .Range("A1:Z" & .cells(.Rows.count, "A").End(xlUp).row)
.AutoFilter
.AutoFilter field:=1, Criteria1:=arr, Operator:=xlFilterValues
End With
End With
End Sub
Less is more. I adapted the code provided by #FaneDuru utilising some shortcuts. Please note that when it comes to AutoFilter, there’s (usually) no need to specify the complete range you want to filter – it filters all rows meeting the criteria so last column is irrelevant. As long as the data is contiguous, there’s no need to specify the last row either.
Provided for interest only.
Sub testFilter()
Dim Arr
Arr = Sheets("Dashboard").Range("B4:B11").Value
Arr = Application.Transpose(Application.Index(Arr, 0, 1))
With Sheets("Database").Range("A1").CurrentRegion
.AutoFilter 1, Array(Arr), 7
End With
End Sub
Try this:
Sub SubRangeBasedAutofilter()
'Declarations.
Dim RngCell As Range
Dim RngCriteria As Range
Dim StrCriteria() As String
Dim DblCriteriaCount As Double
'Selecting Dashboard sheet.
Sheets("Dashboard").Select '<-IS THIS NECESSARY?
'Setting RngCriteria.
Set RngCriteria = Sheets("Dashboard").Range("B4:B11")
'Redeclaring StrCriteria() with proper size.
ReDim StrCriteria(Excel.WorksheetFunction.Max(Excel.WorksheetFunction.CountA(RngCriteria) - 1, 1))
'Covering each in RngCriteria.
For Each RngCell In RngCriteria
'Checking if RngCell is not empty.
If RngCell.Value <> "" Then
'Storing the criteria.
StrCriteria(DblCriteriaCount) = "=" & RngCell.Value
DblCriteriaCount = DblCriteriaCount + 1
End If
Next
'Focusing Database sheet.
With Sheets("Database")
'Turning off any eventual autofilter.
.AutoFilterMode = False
'Setting a new autofilter.
With .Range("A1:Z" & .Cells(.Rows.Count, "A").End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:=StrCriteria, Operator:=xlFilterValues
End With
End With
End Sub

How to delete rows with selected text?

I have sheet1 with every other cell on column "B" has the following letteres, "LLC". My vba script should clear all "LLC" and horizontally delete entire ROW.
The code I have already used:
Sub deleteRowswithSelectedText()
For Each CELL In Selection
If CELL.Value(i, 2) = "LLC" Then
Rows(CELL.Row).ClearContents
End If
Next
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Try this, If you want to loop through each cell and test it you can, but you will need to loop from the bottom to the top. Another way is to use a filter and delete all the visible rows at the same time.
Dim lr As Long
Dim i As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "B") = "LLC" Then
Cells(i, "B").EntireRow.Delete
End If
Next i
Another way is to use a filter and delete every row that has "LLC" in column B
With ActiveSheet
.AutoFilterMode = False
With Range("A1").CurrentRegion
.AutoFilter Field:=2, Criteria1:="LLC"
On Error Resume Next
.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilterMode = False
End With
These are just examples, there are many way to accomplish this task.
The code below is probable closer to what you were trying to do.
With Sheets("Sheet1") 'Change to your worksheet name
For Each CELL In .Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
If CELL.Value = "LLC" Then
CELL.EntireRow.Delete
End If
Next CELL
End With

Subtract Single Cell Value from Column Until Empty Cell

I'm looking to 'normalize' a column of data by setting the minimum value to 0 and shifting the entire column's data by the difference of the min value and 0.
The code should be simple, but I can't find the appropriate range selection to stop the code when it reaches a blank cell.
Below is the core that I've unsuccessfully been working off of trying to recognize the first empty cell in column U after U9 up to U700 and correspondingly stop subtracting in column Z. Example screenshots are attached. Thank you!
Private Sub CommandButton1_Click()
[Z9:Z700] = [U9:U700-U8]
End Sub
This is what I get:
This is what I would like to get:
Try this:
Sub foo()
Dim lRow As Long
With ActiveSheet
lRow = .Cells(Rows.Count, "U").End(xlUp).Row
.Range("U9:U" & lRow).Copy .Range("Z9")
With .Range("U8")
.Formula = "=MIN(U9:U" & lRow & ")"
.Copy
End With
.Range("Z9:Z" & lRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract
Application.CutCopyMode = False
End With
End Sub
EDIT:
If you have formulas in Column U, below your list of numbers, which are returning blank values, then this revision might work better for you:
Sub foo2()
Dim lRows As Long
With ActiveSheet
lRows = WorksheetFunction.Count(.Range("U9:U700"))
.Range("U8").Formula = "=MIN(" & .Range("U9").Resize(lRows, 1).Address(0, 0) & ")"
.Range("U9").Resize(lRows, 1).Copy
.Range("Z9").PasteSpecial Paste:=xlPasteValues
.Range("U8").Copy
.Range("Z9").Resize(lRows, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlSubtract
End With
Application.CutCopyMode = False
End Sub

AutoFilter to find blank cells

I am trying to apply an autofilter in VBA for three different criterias in the same field. Once I have applied the filter I would like to find all those cells that are blank, can anyone advise?
Sub ApplyAutoFiler()
Dim ws As Worksheet
Dim I, j, NumberOfErrors As Long
IsErrors = False
Set ws = Sheets("Assessments")
NumberOfErrors = 0
Dim Z As Range
Set Z = Cells(4, 3).EntireColumn.Find("*", SearchDirection:=xlPrevious)
If Not Z Is Nothing Then
NumberOfRows = Z.Row
End If
For I = 4 To NumberOfRows
With ws
.AutoFilterMode = False
.Range("W4:AA4").AutoFilter Field:=1, Criteria1:=Array("A", "B", "C"), Operator:=xlFilterValues
.Cells.SpecialCells(xlCellTypeBlanks).Interior.Color = 65535
.AutoFilterMode = False
End With
Next I
End Sub
I ended up doing this as a nested if statement
If Range("W" & i).Value = "A" Or Range("W" & i).Value = "B" Or Range("W" & i).Value = "C" Then
If Range("AD" & i).Value = "" Then
Range("AD" & CStr(i)).Interior.ColorIndex = 3
NumberOfErrors = NumberOfErrors + 1
End If
End If
This seemed to get me close (it also assumes you have a worksheet called "Assessments"):
Sub ApplyAutoFiler()
Dim ws As Worksheet
Set ws = Sheets("Assessments")
With ws
.AutoFilterMode = False
.Range("A:AZ").AutoFilter Field:=23, Criteria1:=Array("a", "b", "c"), Operator:=xlFilterValues
.Cells.SpecialCells(xlCellTypeBlanks).Interior.Color = 65535
.AutoFilterMode = False
End With
End Sub
I know this treads had been quite long. But just want to share. To filter out blank cells, you could use autofilter using the following criteria:
Worksheets("sheet name").Range("A1").autoFilter Field:=18, Criteria1:=(Blanks)
"Field" refers to the column numbers. As for "Criteria1", it can be either
Criteria1:=(Blanks)
or
Criteria1:="="
or
Criteria1:=""
Something I just discovered today about filtering for blanks using VBA code. Be sure to include this in ALL code where you need to have blank cells:
' Get Rows with blanks
WorkRange.AutoFilter Field:=1, Criteria1:="=", Operator:=xlOr, Criteria2:="=" & ""
' Hides Rows with blanks ... same idea with the "<>" for operator
WorkRange.AutoFilter Field:=1, Criteria1:="<>", Operator:=xlOr, Criteria2:="<>" & ""
The first criteria gets true blank cells and those cells with hidden/non-printable characters, the 2nd criteria gets those cells containing an empty string. Excel user-interface handles this nicely, but VBA code requires both criteria.
This undocumented caveat just cost me several hours of debugging, not to mention a few choice words from my manager about "I thought we were removing the blanks from these columns..."
Just thought I would share, in the hopes of saving you all some headaches.
You don't need VBA for this. You can use Conditional Formatting for this. See this example
In the CF rule, set this formula
=AND($AA5="",OR($W5="a",$W5="b",$W5="c"))
ScreenShot
If you still want VBA then see this
Sub Sample()
Dim blnkRange As Range, rng As Range, aCell As Range
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Assessments")
With ws
'~~> Sample range for testing purpose
Set rng = .Range("W4:AA11")
.AutoFilterMode = False
With rng
'~~> Filter on "a","b","c"
.AutoFilter Field:=1, Criteria1:=Array("a", "b", "c"), Operator:=xlFilterValues
'~~> Then filter on blanks on Col AA
.AutoFilter Field:=5, Criteria1:="="
'~~> Using offset. Assuming that Row 4 has headers
Set blnkRange = .Offset(1, 0).SpecialCells(xlCellTypeVisible).Cells
End With
.AutoFilterMode = False
End With
'~~> This will give you the blank cells in Col AA
If Not blnkRange Is Nothing Then
For Each aCell In blnkRange
'~~> Color the blank cells red in Col AA
If aCell.Column = 27 Then aCell.Interior.ColorIndex = 3
Next
End If
End Sub

Resources