How to get the starting and ending rownum when using excel Autofilter function in VBA.
I have a set of 500k+ records. and use filters on a particular column. Due to this because of filters the starting rownum might change since other records are hidden in autofilter
so on using the autofilter i might end with startrow as 74562 and ending 87000.
Can someone show a macro which could output the startrow and endrow for every filter I use.
The data is sorted so any filter would be a fixed consecutive bunch
EDIT:
I have realized that the following code gives the result but in range
MsgBox ActiveSheet.Range("A2:A81000").Rows.SpecialCells(xlCellTypeVisible).Address
It shows result as $A$73351:$A$77343. But I just want the 73351 in StartRow variable and 77343 in EndRow variable. How to do that?
You ask how to return the row number of the first and last row in a range. This is how:
Dim r As Range
Dim StartRow As Long
Dim EndRow As Long
Set r = ActiveSheet.Range("A2:A81000").Rows.SpecialCells(xlCellTypeVisible)
' r is now $A$73351:$A$77343
StartRow = r.Row ' returns 73351
EndRow = r.Row + r.Rows.Count - 1 ' returns 77343
dim rRange as Range
Set rRange = Range("A1")
Debug.Print rRange.Offset(1, 0).Row
Debug.Print rRange.Offset(ActiveSheet.Rows.Count - 1, 0).End(xlUp).Row
You can try this piece of code:
Sub Get_Filtered_Range()
Dim oWS As Worksheet
Dim oRng As Range
Dim oColRng As Range
Dim oInRng As Range
oWS = ActiveSheet
'Trigger any autofilter if needed
'oWS.UsedRange.AutoFilter(Field:=2, Criteria1:="Test")
oRng = oWS.Cells.SpecialCells(xlCellTypeVisible)
oColRng = oWS.Range("A2:A"&ActiveSheet.Rows.Count)
oInRng = Intersect(oRng, oColRng)
'display the values in the VBEditor
Debug.Print("Filtered Range is " & oInRng.Address)
Debug.Print("First Row Filtered Range is " & oInRng.Rows(1).Row)
End Sub
Adapted from here
Related
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
I am brand-new to VBA.
I have two worksheets in the same workbook. The first worksheet, shStudentInfo, contains all of the information for each of my students, one row per StudentID (B4 in the code). The second worksheet, shSchedData, contains their schedules where there may be 0-14 rows per StudentID, depending on how many courses each student is taking.
I am attempting to use a loop and VLOOKUP with a dynamic range to extract the course name from each row of shSchedData and copy it to the appropriate cell in shStudentInfo, then move down one row. Currently I've hardcoded cell "CO4" as the appropriate cell although I will also need to make that reference move one cell to the right for each pass through the loop.
Here is my inelegant code:
Option Explicit
Dim MyRow As Long
Sub StudentSchedules()
Dim EndRow As Long
Dim MyRng As Range
shSchedData.Activate
'hard code first row of data set
MyRow = 3
'dynamic code last row of data set
EndRow = shSchedData.Range("A1048575").End(xlUp).Row
'create a dynamic range, a single row from shSchedData
Set MyRng = ActiveSheet.Range(Cells(MyRow, 1), Cells(MyRow, 9))
'Loop through entire data set one line at a time
Do While MyRow <= EndRow
shSchedData.Select
MyRng = ActiveSheet.Range(Cells(MyRow,1),Cells(MyRow,9))
shStudentInfo.Select
'Import course name from shSchedData worksheet
Range("CO4").Select
ActiveCell.Clear
ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng,6,0)"
'The above line results in a #NAME? error in CO4 of shStudentInfo
'Also tried:
'ActiveCell.Formula = "=VLOOKUP(B4,'Schedule Data'!& MyRng.Address,6,0)"
'increment counter
MyRow = MyRow + 1
Loop
End Sub
The following rewrite will get your code working to the extent that its purpose can be determined.
The VLOOKUP formula does not appear correct and in any event, there might be a better method of retrieving the data. However, I cannot determine your end purpose from your narrative or code. Sample data together with expected results would help.
Option Explicit
'I see no reason to put this here
'dim myRow As Long
Sub StudentSchedules()
Dim myRow, endRow As Long, myRng As Range
'no need to activate, just With ... End With block it
With shSchedData
'assigned a strarting value
myRow = 3
'dynamic code last row of data set
endRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'Loop through entire data set one line at a time
Do While myRow <= endRow
'create a dynamic range, a single row from shSchedData
Set myRng = .Range(.Cells(myRow, 1), .Cells(myRow, 9))
'Import course name from shSchedData worksheet
shStudentInfo.Range("CO4").Offset(0, myRow - 3).Formula = _
"=VLOOKUP(B4, " & myRng.Address(external:=True) & ", 6, false)"
'increment counter
myRow = myRow + 1
Loop
End With
End Sub
I came up with this, see if it fits you
Dim a As Double
Dim b As Double
Dim ml As Worksheet
Dim arrayrng As Variant
Dim i As Integer
Dim x As String
Dim y As String
Set ml = Worksheets("Master Data")
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
For i = a To b - 1
a = ml.Cells(Rows.Count, 11).End(xlUp).Row
b = ml.Cells(Rows.Count, 1).End(xlUp).Row
arrayrng = "E" & a + 1
x = "=VLOOKUP(" & arrayrng
y = ",'Data Base'!I:J,2,0)"enter code here
Range("K" & a + 1) = x + y
Next
So I am learning VBA, I know how to program on Matlab and some C++. I am wondering how I can use the CountA to count all of the cells used on a specific row and only that row. ( I have multiple examples on ranges and columns but none on a Row only).I cannot use a range because I want to use this VBA in the future and this row will have a number of variables changing. I would also like to have the content(text) of those cells moved to another location with no spaces between them because right now they have three spaces between each used cell.
So far I have this code which isn't very much for the countA of the first row
Sub CountNonBlankCells()
Dim numcompanies As Integer
n = Sheet1.CountA(Rows(1))
Worksheets("start on this page").Range("B2") = n
End Sub
I have nothing for the part where I take that data from each cell to another location.
Sure you can use a Range. Your question is pretty broad, but for tutorial purpose ... here's a piece of code that counts the number of nonblank cells in a number of rows and shows you what's in each of them ...
Sub TestCount()
Dim mySht As Worksheet
Dim myRng As Range, oRow As Range
Dim lstRow As Long, lstCol As Long
Dim nUsed As Long
Dim iLoop As Long
Set mySht = Worksheets("Sheet13")
lstRow = mySht.Range("A1").End(xlDown).Row
lstCol = mySht.Range("A1").End(xlToRight).Column
Set myRng = mySht.Range(Cells(1, 1), Cells(lstRow, lstCol))
Debug.Print "Number of Rows is " & myRng.Rows.Count
For Each oRow In myRng.Rows
nUsed = Application.CountA(oRow)
For iLoop = 1 To nUsed
Debug.Print oRow.Cells(1, iLoop)
' assign oRow.Cells(1,iLoop) to something else here
Next iLoop
Next oRow
End Sub
As per your question I am assuming that you want to copy a complete row having blank cells to another location(row) but without blank cells.
I guess this is what you want.
Sub CountNonBlankCells()
Dim CurrentSh As Worksheet, TargetSh As Worksheet
Dim LastColumn As Long, count As Long
Dim MyRange As Range
Dim i As Long, temp As Long
Dim RowNum As Long
Set CurrentSh = ThisWorkbook.Worksheets("Sheet1")
Set TargetSh = ThisWorkbook.Worksheets("Sheet2")
RowNum = ActiveCell.Row
LastColumn = CurrentSh.Cells(RowNum, Columns.count).End(xlToLeft).Column
Set MyRange = CurrentSh.Rows(RowNum)
count = WorksheetFunction.CountA(MyRange)
temp = 1
For i = 1 To LastColumn
If Not IsEmpty(CurrentSh.Cells(RowNum, i)) Then
TargetSh.Cells(RowNum, temp).Value = CurrentSh.Cells(RowNum, i).Value
temp = temp + 1
End If
Next i
End Sub
Above code will copy active row in Sheet1 to Sheet2 at same row number without blank cells.
This is my first attempt at VBA, so I apologize for my ignorance. The situation is as follows: I have a spreadsheet that consists of 4 columns and 629 rows. When I am trying to do is iterate through the 4 cells in each row and check for a blank cell. If there is a row that contains a blank cell, I want to cut it from Sheet1 and paste it into the first available row in Sheet2.
(Ideally the number of columns AND the number of rows is dynamic based on each spreadsheet, but I have no idea how to iterate through rows and columns dynamically)
Sub Macro1()
'
' Macro1 Macro
' Move lines containing empty cells to sheet 2
'
' Keyboard Shortcut: Ctrl+r
'
Dim Continue As Boolean
Dim FirstRow As Long
Dim CurrentRow As Long
Dim LastRow As Long
Dim EmptySheetCount As Long
Dim Counter As Integer
'Initialize Variables
LContinue = True
FirstRow = 2
CurrentRow = FirstRow
LastRow = 629
EmptySheetCount = 1
'Sheets(Sheet1).Select
'Iterate through cells in each row until an empty one is found
While (CurrentRow <= LastRow)
For Counter = 1 To 4
If Sheet1.Cells(CurrentRow, Counter).Value = "" Then
Sheet1.Cells(CurrentRow).EntireRow.Cut Sheet2.Cells(EmptySheetCount, "A")
EmptySheetCount = EmptySheetCount + 1
Counter = 1
CurrentRow = CurrentRow + 1
GoTo BREAK
Else
Counter = Counter + 1
End If
Counter = 1
BREAK:
Next
Wend
End Sub
When I run it, I typically get an error around the Sheet1.Cells(CurrentRow, Counter).Value = "" area, so I know I'm referencing sheets incorrectly. I've tried Sheets(Sheet1), Worksheets("Sheet1") and nothing seems to be working. When I do change to Worksheets("Sheet1"), however, it runs and just freezes Excel.
I know I'm doing multiple things wrong, I just know way too little to know what.
Thanks a lot in advance. And sorry for the crap formatting.
There are a few things wrong with your code so rather than go through them individually here is a basic looping version that does what you're after.
Sub moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Dim lastColumn As Integer
Dim lastRow As Integer
Dim destinationRow As Integer
Set wksData = Worksheets("Sheet1")
Set wksDestination = Worksheets("Sheet2")
destinationRow = 1
lastColumn = wksData.Range("XFD1").End(xlToLeft).Column
lastRow = wksData.Range("A1048576").End(xlUp).Row
For i = lastRow To 1 Step -1 'go 'up' the worksheet to handle 'deletes'
For j = 1 To lastColumn
If wksData.Cells(i, j).Value = "" Then 'check for a blank cell in the current row
'if there is a blank, cut the row
wksData.Activate
wksData.Range(Cells(i, 1), Cells(i, lastColumn)).Cut
wksDestination.Activate
wksDestination.Range(Cells(destinationRow, 1), Cells(destinationRow, lastColumn)).Select
ActiveSheet.Paste
'If required this code will delete the 'cut' row
wksData.Rows(i).Delete shift:=xlUp
'increment the output row
destinationRow = destinationRow + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next j
Next i
set wksData = Nothing
set wksDestination = Nothing
End Sub
There are other ways that will achieve the same outcome but this should give you and idea of how to use loops, sheets, ranges, etc.
The lastColumn and lastRow variables will find the the last column/row of data in the given columns/rows (i.e, in my code it finds the last column of data in row 1, and the last row of data in column A).
Also, you should get into the habit of debugging and stepping through code to identify errors and see exactly what each line is doing (this will also help you learn too).
You might find this of use.
It uses an array variable to store the values of the cells in the row to be moved. It does not use cut and paste, so only transfer the data values, and the code does not require activation of the required sheets.
The destination rows are in the same order as the rows on the original sheet.
The method used to find the last cell used in the row and column is more elegant than other answers given.
Option Explicit
Public Sub test_moveData()
Dim wksData As Worksheet
Dim wksDestination As Worksheet
Set wksData = shtSheet1 ' Use the Codename "shtSheet1" for the worksheet. ie the value of the sheet property that is displayed as "(Name)"
Set wksDestination = shtSheet2
moveData wksData, wksDestination
End Sub
Public Sub moveData(wksData As Worksheet, wksDestination As Worksheet)
Dim ilastColumn As Integer
Dim ilastRow As Integer
Dim iRow As Long
Dim iColumn As Long
Dim iDestinationRowNumber As Integer
Dim MyArray() As Variant
Dim rngRowsToDelete As Range
iDestinationRowNumber = 1
ilastColumn = wksData.Cells(1, wksData.Columns.Count).End(xlToLeft).Column
ilastRow = wksData.Cells(wksData.Rows.Count, 1).End(xlUp).Row
ReDim MyArray(1, ilastColumn)
Set rngRowsToDelete = Nothing
For iRow = 1 To ilastRow Step 1 'No need to go 'up' the worksheet to handle 'deletes'
For iColumn = 1 To ilastColumn
If wksData.Cells(iRow, iColumn).Value = "" Then 'check for a blank cell in the current row
MyArray = wksData.Range(wksData.Cells(iRow, 1), wksData.Cells(iRow, ilastColumn)).Value
wksDestination.Range(wksDestination.Cells(iDestinationRowNumber, 1),
wksDestination.Cells(iDestinationRowNumber, ilastColumn) _
).Value = MyArray
'Store the rows to be deleted
If rngRowsToDelete Is Nothing Then
Set rngRowsToDelete = wksData.Rows(iRow)
Else
Set rngRowsToDelete = Union(rngRowsToDelete, wksData.Rows(iRow))
End If
'increment the output row
iDestinationRowNumber = iDestinationRowNumber + 1
Exit For 'no need to carry on with this loop as a blank was already found
End If
Next iColumn
Next iRow
If Not rngRowsToDelete Is Nothing Then
rngRowsToDelete.EntireRow.Delete shift:=xlUp
End If
Set rngRowsToDelete = Nothing
Set wksData = Nothing
Set wksDestination = Nothing
End Sub
' enjoy
At my work we get Excel files with multiple worksheets that are pulled from various data sources. Some of the worksheets have a standardized disclaimer inserted at the end, some don't. But when the disclaimers appear they always start with the same text and always appear in the same column. I'm trying to write a VBA script that will search through an entire Excel file; determine if disclaimers are present, and if so, what row they start on; then clear all the cells from that row to the last used row.
As far as I can tell by hunting through StackOverflow and other resources, the code below should work. But for some reason, it never actually identifies when the key sub-string is present (even when it is). Can anyone point out where I am going wrong?
Option Explicit
Option Base 1
Sub Delete_Disclaimers()
' Turn off screen updating for speed
Application.ScreenUpdating = False
' Define variables
Dim ws As Worksheet
Dim TextCheck As String
Dim StartRow As Integer
Dim EndRow As Integer
Dim SearchColumn As Integer
Dim CheckVal As Integer
Dim CurrentCell As Range
Dim RowCount As Integer
Dim SearchText As String
' Cycle through each worksheet in the workbook
For Each ws In ActiveWorkbook.Worksheets
'Set some initial variables for this worksheet
SearchColumn = 2
StartRow = 1
SearchText = "Disclaimer"
' Set EndRow to the last row used in the worksheet
EndRow = CInt(ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
' Find the cell, if any, that has the text by searching just in column B to speed things up. Also limit to the first 200 rows
' for speed since there don't seem to have any sheets longer than that.
For RowCount = 1 To 200
Set CurrentCell = ws.Cells(2, RowCount)
TextCheck = CurrentCell.Text
If Not TextCheck = "" Then
CheckVal = InStr(1, TextCheck, SearchText, 1)
If CheckVal > 0 Then
StartRow = RowCount
MsgBox ("Start Row is " & CStr(StartRow))
Exit For
End If
End If
Next RowCount
' If the search text was found, clear the range from the start row to the end row.
If StartRow > 1 Then
ws.Range(ws.Cells(1, StartRow), ws.Cells(50, EndRow)).Clear
End If
' Loops to next Worksheet
Next ws
' Turn screen updating back on
Application.ScreenUpdating = True
' Display a message box that all sheets have been cleared, now that screenupdating is back on
MsgBox "All Worksheets have been cleared!"
End Sub
Your syntax for Cells is incorrect. It should be Cells(row, col). You have row and col transposed.
My solution ended up being a combination of both of the answers above. But the .Clear section was definition a major problem I had overlooked. Here is the full updated code in case it helps anyone else with similar problem.
Option Explicit
Option Base 1
Sub Delete_Portfolio_Holdings()
' Turn off screen updating for speed
Application.ScreenUpdating = False
' Define variables
Dim ws As Worksheet
Dim TextCheck As String
Dim StartRow As Integer
Dim EndRow As Integer
Dim SearchColumn As Integer
Dim CheckVal As Integer
Dim CurrentCell As Range
Dim RowCount As Integer
Dim SearchText As String
Dim ClearRange As Range
Dim WScount As Integer
Dim cws As Integer
' Cycle through each worksheet in the workbook
WScount = ActiveWorkbook.Worksheets.Count
For cws = 1 To WScount
'Set some initial variables for this worksheet
SearchColumn = 2
StartRow = 1
SearchText = "Disclaimer"
Set ws = ActiveWorkbook.Worksheets(cws)
' Set EndRow to the last row used in the worksheet
EndRow = CInt(ws.UsedRange.SpecialCells(xlCellTypeLastCell).Row)
' Find the cell, if any, that has the text by searching just in column B to speed things up. Also limit to the first 200 rows
' for speed since you don't seem to have any sheets longer than that. You can always change to increase if necessary. Cells.Find
' does not return anything if there is no match for the text, so CurrentRow may not change.
With ws.Range("b1:b200")
Set CurrentCell = ws.Cells.Find(What:=SearchText, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not CurrentCell Is Nothing Then
StartRow = CInt(CurrentCell.Row)
End If
End With
' Now if the text was found we now have identified the start and end rows of the caveats, we can clear columns A through BB with the .Clear function. Choice of column BB is arbitary.
If StartRow > 1 Then
Set ClearRange = ws.Range(("A" & StartRow), ("BB" & EndRow))
MsgBox ("ClearRange is " & CStr(ClearRange.Address))
ClearRange.Clear
End If
' Loops to next Worksheet
Next cws
' Turn screen updating back on
Application.ScreenUpdating = True
' Display a message box that all sheets have been cleared, now that screenupdating is back on
MsgBox "All Worksheets have been cleared!"
End Sub