Find the last filled row in a filtered column without dropping the Autofilter - excel

How do I get the position of the last non-empty cell in a filtered column without dropping the applied Autofilter? I understand it's easy to get the number of the last visible row with
Dim ws as Worksheet, rng As Range
Set rng = Range(Letter & 1 & ":" & Letter & 1) ' where Letter is the letter code of the column
GetLastVisibleRow = ws.Range(Split(ws.Cells(, rng.Column).Address, "$")(1) & ws.Rows.count).End(xlUp).row
but I need the number of the last filled row instead. At the same time, I'd like to avoid setting
ws.AutoFilterMode = False
if it's possible.
Thanks in advance.

Probably not the most efficient or fastest method, but this appears to work:
Function GetLastCellOfColumn(ColLetter As String) As Range
Dim Col As Range
Dim Rw As Long
Set Col = Range(ColLetter & ":" & ColLetter)
Set GetLastCellOfColumn = Intersect(ActiveSheet.UsedRange, Col)
For Rw = GetLastCellOfColumn.Cells.Count To 1 Step -1
If Len(GetLastCellOfColumn.Cells(Rw).Value) > 0 Then
Set GetLastCellOfColumn = GetLastCellOfColumn.Cells(Rw)
Exit Function
End If
Next
End Function

A charming solution by #jkpieterse plus a useful comment by #BigBen is exactly what I was looking for. Just to finalize the thread, the function returning the row number is
Function GetLastFilledCellOfColumn(ws As Worksheet, ColLetter As String) As Long
Dim Col As Range, Urng As Range, Rw As Long
Set Col = ws.Range(ColLetter & ":" & ColLetter)
Set Urng = Intersect(ws.UsedRange, Col)
For Rw = Urng.Cells.count To 1 Step -1
If Not IsEmpty(Urng.Cells(Rw)) Then
GetLastFilledCellOfColumn = Rw
Exit Function
End If
Next
End Function
Problem solved.

So maybe this is an alternative way to look into:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("_FilterDatabase").Columns(col)
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
I'm afraid I rushed this a little and might have made a mistake but will have to get going. Hopefully you understand whats going on =)
Edit:
The above would definately work, but as figured out through the chat, there is actually a ListObject involved, called Table1, which throws of the AutoFilter range. So here are two alternative ways of doing the same thing:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .Range("Table1")
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub
Or, when you don't know the name of the table:
Sub Test()
Dim rng As Range
Dim col As Long: col = 2 'Change to whichever column you interested in
Dim rw as Long
With Sheet1 'Change to whichever sheets CodeName you need
Set rng = .ListObjects(1).Range
rw = .Evaluate("MAX(IF(" & rng.Address & "<>"""",ROW(" & rng.Address & ")))")
End With
End Sub

Related

Search for a column name and paste data

I want to paste the formula into a column by searching the column using its name.
My column name is Date1.
I want to find Date1 in my sheet and paste the following formula:
IF(ISBLANK(B5),"""",IF(ISBLANK(O5)=TRUE,""Missing PSD"",TODAY()-O5))
This should be calculated until the last row of Date1 column.
Kindly share any knowledge you have on this, it'd be very helpful.
Sub FillFormula()
Set wb = ActiveWorkbook
Dim sh As Worksheet, lastRow As Long
Set sh = wb.Worksheets("Sheet1")
lastRow = sh.Range("O" & Rows.count).End(xlUp).Row 'chosen O:O column, being involved in the formula...
sh.Range("AC5:AC" & lastRow).Formula = "=IF(ISBLANK(B5),"""",IF(ISBLANK(O5)=TRUE,""Missing PSD"",TODAY()-O5))"
lastRow2 = sh.Range("R" & Rows.count).End(xlUp).Row
sh.Range("AD5:AD" & lastRow).Formula = "=IF(ISBLANK(B5),"""",IF(ISBLANK(R5)=TRUE,""Missing RSD"",TODAY()-R5))"
End Sub
This is the code I am currently using and it works properly but my columns might change so I do not want to use the column character but instead the column name to paste the data into the correct column.
Try the next code, please. It still calculates the last row based on O:O column. If the column "Date1" has already formulas to be overwritten, I can easily adapt the code to use it:
Sub FillFormulaByHeader()
Dim wb As Workbook, sh As Worksheet, lastRow As Long, celD As Range
Set wb = ActiveWorkbook
Set sh = wb.Worksheets("Sheet1")
'Find the header ("Date1"):
Set celD = sh.Range(sh.Range("A1"), sh.cells(, cells(1, Columns.count).End(xlToLeft).Column)).Find("Date1")
If celD Is Nothing Then MsgBox "Nu such header could be found...": Exit Sub
lastRow = sh.Range("O" & rows.count).End(xlUp).row 'it can be easily changed for column with Date1 header
sh.Range(sh.cells(5, celD.Column), sh.cells(lastRow, celD.Column)).Formula = _
"=IF(ISBLANK(B5),"""",IF(ISBLANK(O5)=TRUE,""Missing PSD"",TODAY()-O5))"
End Sub
For simplicity, let's assume you have Headers in Row1. We now need to find out which column our Date1 Value is in. We can do this by simply looping over the Header Range an check if the Value equals "Date1". Now we can use this information to construct the final Range.
Sub FindDate1()
Dim c As Range
Dim date1Column as integer
Dim finalRange As Range
For Each c In Range("A1:Z1")
If c.Value = "Date1" Then
date1Column = c.Column
Exit For
End If
Next c
If date1Column = 0 Then
'in case "Date1" was not found
Exit Sub
Else
Set finalRange = Range(Cells(2, date1Column), Cells(2, date1Column).End(xlDown))
For Each c In finalRange
c.Formula = "=IF(ISBLANK(B" & c.Row & "),"""",IF(ISBLANK(O" & c.Row & ")=TRUE,""Missing PSD"",TODAY()-O" & c.Row & "))"
Next c
End If
End Sub

how to get last row that has velue Excel VBA within a range

I am new to VBA Macro. i just want to know how to get the last row that has value within a range
Set MyRange = Worksheets(strSheet).Range(strColumn & "1")
GetLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
this code could find the last row for the whole sheet.. i just want it to find the last non null value cells
(
like in this case in the picture.. for the ("A8") range, the last row result should be ("A9:B9")
"A9:B9" cannot be last row... It is a range.
If you need such a range, but based on the last empty row, starting from a specific cell, you can use the next approach:
Sub testLastRowRange()
Dim sh As Worksheet, myRange As Range, lastRow As Long, strColumn As String
Dim lastCol As Long, endingRowRng As Range, strSheet As String
strSheet = ActiveSheet.Name 'please, use here your real sheet name
Set sh = Worksheets(strSheet)
strColumn = "A"
Set myRange = sh.Range(strColumn & 8)
lastRow = myRange.End(xlDown).row
lastCol = myRange.End(xlToRight).Column
Set endingRowRng = sh.Range(sh.Cells(lastRow, myRange.Column), sh.Cells(lastRow, lastCol))
Debug.Print endingRowRng.address
End Sub
For your specific example you could use CurrentRegion property.
This is based on the ActiveCell which is not generally advisable.
Sub x()
Dim r As Range
Set r = ActiveCell.CurrentRegion
MsgBox r.Address
End Sub

VBA - Highlight/Delete row if Range is Empty

I have a range of data, with CASE ID's in Column A, and Issues (1 through 10, or Columns B through K) in Columns B onwards.
Once certain issues are ruled out as 'normal', they would be removed from the Issues sheet based on their respective column. For ex: CASE ID #25, Issue 4 is ruled OK, then it would be deleted from Row 25, Column 5 (or Column E) but the CASE ID would remain.
The goal is that by doing this check after the fact, it may leave certain rows entirely blank, from Column B onwards (since the CASE ID would already be there.)
My code doesn't function successfully. Once run, it highlights several rows that are not entirely blank in the target range.
I'm trying to pinpoint rows in the range B2:P & lastrow where the entire row is blank, and then highlight these rows and subsequently delete them.
Code:
Public Sub EmptyRows()
lastrow = Sheets("Issues").Cells(Rows.Count, "A").End(xlUp).row
On Error Resume Next
Sheets("Issues").Activate
For Each rng In Range("B2:P" & lastrow).Columns
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Interior.ColorIndex = 11
'rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next rng
Application.ScreenUpdating = True
End Sub
The purpose of first highlighting is to test the code works. If successful, they would be deleted entirely.
Your description says Columns B through K, but your code has B through P...
You can do it like this (adjust resize for actual columns involved):
Public Sub EmptyRows()
Dim lastRow As Long, sht As Worksheet, c As Range, rngDel As Range
Set sht = Sheets("Issues")
For Each c In sht.Range(sht.Range("A2"), sht.Cells(Rows.Count, 1).End(xlUp)).Cells
If Application.CountA(c.Offset(0, 1).Resize(1, 10)) = 0 Then
'build range to delete
If rngDel Is Nothing Then
Set rngDel = c
Else
Set rngDel = Application.Union(rngDel, c)
End If
End If
Next c
'anything to flag/delete ?
If Not rngDel Is Nothing Then
rngDel.EntireRow.Interior.ColorIndex = 11
'rngDel.EntireRow.Delete '<< uncomment after testing
End If
End Sub
Once run, it highlights several rows that are not entirely blank in the target range.
This is because you are selecting all blanks, instead of only rows where the entire row is blank.
See the code below
Public Sub EmptyRows()
With Sheets("Issues")
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
Dim rng as Range
For Each rng In .Range("B2:B" & lastrow)
Dim blankCount as Integer
blankCount = Application.WorksheetFunction.CountA(rng.Resize(1,.Range("B:P").Columns.Count))
If blankCount = .Range("B" & lastRow & ":P" & lastRow).Columns.Count Then
Dim store as Range
If store Is Nothing Then Set store = rng Else: Set store = Union(rng, store)
End If
Next rng
End With
store.EntireRow.Interior.ColorIndex = 11
'store.EntireRow.Delete
End Sub
Gathering the ranges first and then modified them (changing color or deleting) will help to execute the code faster.
Here is another approach, using CountA
For Each cell In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Dim rng As Range
Set rng = Range("A" & cell.Row & ":" & "P" & cell.Row)
If Application.WorksheetFunction.CountA(rng) = 1 Then
rng.EntireRow.Interior.ColorIndex = 11
End If
Next cell

Excel VBA offset function

I have an Excel file with information in column A and column B. Since these columns could vary in the number of rows I would like to use the function offset so that I could print the formula in one time as an array rather than looping over the formula per cell (the dataset contains almost 1 million datapoints).
My code is actually working the way I want it to be I only can't figure out how to print the code in Range(D1:D5). The outcome is now printed in Range(D1:H1). Anybody familiar how to use this offset within a for statement?
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set example = Range("A1:A1")
For i = 1 To LastRow
example.Offset(0, i + 2).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
End Sub
Using the Offset(Row, Column), you want to offset with the increment of row (i -1), and 3 columns to the right (from column "A" to column "D")
Try the modified code below:
Set example = Range("A1")
For i = 1 To LastRow
example.Offset(i - 1, 3).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
One way of outputting the formula in one step, without looping, to the entire range, is to use the R1C1 notation:
Edit: Code modified to properly qualify worksheet references
Option Explicit
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
With sht
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set example = .Range(.Cells(1, 1), .Cells(LastRow, 1))
End With
example.Offset(columnoffset:=3).FormulaR1C1 = "=sum(rc[-3],rc[-2])"
End Sub
You don't need to use VBA for this. Simply type =sum(A1:B1) in cell D1 and then fill it down.
If you're going to use VBA anyway, use this:
Sub checkOffset()
Dim example As Range
Dim sht As Worksheet
Dim LastRow As Long
Set sht = ThisWorkbook.Worksheets("Sheet1")
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set example = Range("A1:A1")
For i = 1 To LastRow
example.Offset(i - 1, 3).Formula = "=SUM(A" & i & ":B" & i & ")"
Next i
End Sub
The way offset works is with row offset, column offset. You want the column to always be fixed at 3 to the right.

Vba comparing then copying two different Sheets

I realize there are a few different similar ideas on here. But I need help with this simple compare function.
My goal is to compare two different cells and if they are the same, replace it with its full non-abbreviated name.
Thank you for your time!!!
I.E
Sheet1 Sheet2
Column H Column A Column B
Dept Dept Department
This is what I have (Yes simple), but the cell H is not updating to the non-abbreviation:
Sub updateDeptNames()
'Format user ID from the email column
Dim ws As Worksheet, ws2 As Worksheet
Dim LastRow As Long, i As Long
Dim tmpArray() As String, tempDept As String
Set ws = ActiveWorkbook.Sheets("Student_Travel_DB") '--> This is the relevant sheet
Set ws2 = ActiveWorkbook.Sheets("gokoutd") '--> This is the relevant sheet
LastRow = 1000 ''Bug finding the last row, had to hard code it
For i = 2 To LastRow 'Iterate through all the rows in the sheet
For j = 2 To 112
tempDept = ws2.Range("A" & j).Value
If ws.Range("H" & i).Value = tempDept Then
ws.Range("H" & i) = ws2.Range("B" & j).Value
End If
Next j
Next i
End Sub
You can more easily use VLOOKUP either on your worksheet or with VBA:
Sub GetFullName()
Dim cl As Range, data As Range, lookUpRng As Range
Set data = Worksheets("Student_Travel_DB").Range("A1:A10")
Set lookUpRng = Worksheets("gokoutd").Range("A1:B10")
On Error Resume Next
For Each cl In data
cl = WorksheetFunction.VLookup(cl, lookUpRng, 2, False)
Next cl
End Sub
You'll need to change your range references.

Resources