VBA : deleteing the information from sheet - excel

I'm wondering if there is more efficient way to clean my sheet. My code takes a long time to run (I have 5000 observations ):
Dim Num_Ligne As Long
Num_Ligne = 8
While Cells(Num_Ligne, 3) <> ""
ActiveSheet.Cells(Num_Ligne, 3).Value = ""
ActiveSheet.Cells(Num_Ligne, 4).Value = ""
ActiveSheet.Cells(Num_Ligne, 5).Value = ""
ActiveSheet.Cells(Num_Ligne, 6).Value = ""
ActiveSheet.Cells(Num_Ligne, 7).Value = ""
ActiveSheet.Cells(Num_Ligne, 8).Value = ""
ActiveSheet.Cells(Num_Ligne, 9).Value = ""
ActiveSheet.Cells(Num_Ligne, 10).Value = ""
Num_Ligne = Num_Ligne + 1
Wend
Thank you for your help !

Clear Contents of a Range
Requirements
Clear the contents of a range.
OP's Solution
Loop through each cell and test if it is empty. Then loop through each column and clear its contents. For 5000 records it tests 5000 times a cell if it is blank and clears the contents of a cell 40.000 times which takes about 10s on my machine.
Solution
Create a reference to all those cells and clear the contents in one go.
The first solution is a 'flavor' of BigBen's solution in the comments which is widely used (popular) and is based on the End property. This (my) solution uses Resize ('flavor').
The second solution is a more reliable version that uses the Find method which may only fail if the worksheet is filtered. The End solution will additionally fail if the last cell on the worksheet is occupied (highly unlikely), if the last row is less than the specified first row (unlikely), and if there are hidden rows (unlikely).
The third solution is kind of a study of the second solution.
For even more insights, study the legendary Siddharth Rout's answer to Error in finding last used cell in Excel with VBA.
The Code
Option Explicit
Sub RangeClearContentsEnd()
Const Cols As String = "C:J"
Const FirstRow As Long = 8
With ActiveSheet.Columns(Cols)
Dim LastRow As Long
LastRow = .Columns(1).Cells(.Rows.Count).End(xlUp).Row
.Rows(FirstRow).Resize(LastRow - FirstRow + 1).ClearContents
End With
End Sub
Sub RangeClearContentsFind()
Const Cols As String = "C:J"
Const FirstRow As Long = 8
With ActiveSheet.Columns(Cols).Rows(FirstRow)
Dim cel As Range
Set cel = .Resize(.Worksheet.Rows.Count - FirstRow + 1, 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If Not cel Is Nothing Then
.Resize(cel.Row - FirstRow + 1).ClearContents
End If
End With
End Sub
Sub RangeClearContentsFindStudy()
Const Cols As String = "C:J"
Const FirstRow As Long = 8
' Define the first row (range) of the range.
Dim rrg As Range: Set rrg = ActiveSheet.Columns(Cols).Rows(FirstRow)
Debug.Print "First Row of the Range : " & rrg.Address(0, 0)
' Define the range referring to the first column from
' the specified first row to the bottom-most row of the worksheet.
Dim frg As Range
Set frg = rrg.Resize(ActiveSheet.Rows.Count - FirstRow + 1, 1)
Debug.Print "First Column to the Bottom: " & frg.Address(0, 0)
' Attempt to find the last non-empty cell in it.
Dim lCell As Range
Set lCell = frg.Find("*", , xlFormulas, , , xlPrevious)
' Validate the last non-empty cell.
If Not lCell Is Nothing Then
Debug.Print "Last Non-Empty Cell: " & lCell.Address(0, 0)
' Define the range from the first specified row
' to the last non-empty cell's row.
Dim drg As Range: Set drg = rrg.Resize(lCell.Row - FirstRow + 1)
Debug.Print "Delete Range: " & drg.Address(0, 0)
' Clear its contents.
drg.ClearContents
Else
Debug.Print "Nothing cleared."
End If
End Sub

The Requirements: To clear the contents of a range.
The Data: The data involved contains a mix of cells (i.e:, some cells have content, others are empty), as could be understood from this line in the question code While Cells (Num_Ligne, 3) <>"".
The figure below represents a sample of the data. There we have cells with a constant value (X), cells with formulas (filled with a pattern), and all other cells are empty. In this sample data the Last Row is the Row 26.
Now let's look at some of the methods to obtain the last row in line with the data involved.
End(xlUp).Row method: In this case, I would suggest not using this method unless it is applied to each of the columns involved, but then it won't be practical.
When applied only to the first column, it returns row 25, instead of row 26.
Find method: In this case, this method will only be effective if it is applied to the entire range.
When applied only to the first column, it also returns row 25.
When applied to the entire range [C:J] it will return the correct row 26.
However, if the last time the Find method was utilized the SearchOrder applied was xlByColumns, then when we run our procedure the method will return row 25, if the SearchOrder was not set to xlByRows in our procedure.
Bear in mind that the LookIn, LookAt, SearchOrder and MatchByte* parameters are saved each time the Find method is applied, therefore these parameters should always be included (*if applicable) to ensure the expected return.
UsedRange: This is one of the few cases where this worksheet property could be used. As in this case, the objective is to set a range from an initial row to the last row with contents of specific columns and then clear the contents of that range. Actually utilizing the UsedRange simplifies the code a lot.
With ActiveSheet
Range(.Rows(8), .Rows(.UsedRange.SpecialCells(xlCellTypeLastCell).Row)).Columns("C:J").ClearContents
End With
Last Row? However, each problem has its own peculiarities, and for this particular problem we should also ask ourselves the question:
In this case, is the last row really necessary?
I think the answer is no. So let's simplify things even more.
With ActiveSheet
Range(.Rows(8), .Rows(.Rows.Count)).Columns("C:J").ClearContents
End With

You have options:
Sub test()
Dim Num_Ligne As Long
Num_Ligne = 8
While Cells(Num_Ligne, 3) <> ""
'ActiveSheet.Cells(Num_Ligne, 3).EntireRow.Clear
ActiveSheet.Range("C" & Num_Ligne & ":J" & Num_Ligne).Clear
Num_Ligne = Num_Ligne + 1
Wend
End Sub

Related

Excel Loop Through all filled cells in row 1

I'm sure this is possible, im just not sure what the code should be. i have 2 sheets: (1)Component which has all the Component Names where an analyst got marked down on, including dates of when the call occurred, and (2)Calculator, which counts the number of times a specific component appeared in a specific week number.
ive created a code which gets the distinct Component Names from the Component Sheet, and then copies and transpose them to the Calculator sheet. all the Component Names are in Row 1 starting from Column D1 then goes to E1, F1, and so on. i want row 2 to display the count or the number of times the component(listed in row 1) appeared in a week.
The code i have only works for columns, i do not know how to make it get the non-empty values of an entire row.
'//here the code i used to transpose Distinct Components from the Component sheet to the Calculator Sheet
Public Sub GetDistinctComponents()
Application.ScreenUpdating = False
Dim lr As Long
lr = Sheets("Components Data").Cells(Rows.Count, "F").End(xlUp).Row
Sheets("Calculator").Unprotect Password:="secret"
Sheets("Components Data").Range("F1:F" & lr).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=ActiveSheet.Range("DW1"), Unique:=True
With ThisWorkbook.Worksheets("Calculator")
.Range(.Range("DW1"), .Range("DW1").End(xlDown)).Copy
.Range("DX1").PasteSpecial xlPasteValues, Transpose:=True
.Columns("DW").EntireColumn.Delete
End With
Sheets("Calculator").Protect Password:="secret", DrawingObjects:=False
End Sub
Here's my Component sheet
And below is my Calculator sheet. as you can see, the code to transpose the distinct Components works fine. i just do not know how to get the value of Row 1 starting from DX so i can store it in a variable which i will use in counting the number of times that component appeared in a week . I'm thinking it should go like this
Component = wsCalculator.Cells(i, "D").Value
But this code only works if i want to get the Values of all cells in Column D, not the values of the cells next to D1
and here's the code i currently have
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
Dim ComponentCount As Integer
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("F2:F" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'//Looping through all filled rows in the Components Data sheet
For i = 2 To wsCalculator.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Component from cell in column "DW"
'Component = wsCalculator.Cells(i, "DW").Value
'//Count the # of calls that got hit in the corresponding Component
If wsCalculator.Cells(i, "DW").Value <> "" Then
ComponentCount = Application.WorksheetFunction.CountIf( _
ComponentRange, component)
wsCalculator.Cells(i, "DX").Value = ComponentCount
End If
Next
End Sub
I'll take a crack at this. I'm not 100% sure what you are doing, but I'm going to assume you will have soon calculations in cells D2, down, and to the right. Is that correct? Try this small code sample to copy from D2 (down and right) on the "Components Data" sheet, and transpose to your "Calculator" sheet.
Sub TransposeThis()
Set Rng = Sheets("Components Data").Range("D2:D7") 'Input range of all fruits
Set Rng_output = Sheets("Calculator").Range("B2") 'Output range
For i = 1 To Rng.Cells.Count
Set rng_values = Range(Rng.Cells(i).Offset(0, 1), Rng.Cells(i).End(xlToRight)) 'For each fruit taking the values to the right which need to be transposed
If rng_values.Cells.Count < 16000 Then 'To ensure that it doesnt select till the right end of the sheet
For j = 1 To rng_values.Cells.Count
Rng_output.Value = Rng.Cells(i).Value
Rng_output.Offset(0, 1).Value = rng_values.Cells(j).Value
Set Rng_output = Rng_output.Offset(1, 0) 'Shifting the output row so that next value can be printed
Next j
End If
Next i
End Sub
Before:
After:
If I got something wrong, post your feedback, and I'll adjust the code to suit your needs.
The code below is your own code, in part, which I commented, and of my own making for those parts where you seemed to have lost your way.
Public Sub CountComponent()
' Locations:-
Dim WsComp As Worksheet
Dim WsCalc As Worksheet
Dim CompRng As Range ' column A
Dim CalcRng As Range ' Calculator!D1:D?)
Dim Rt As Long ' Target row (in WsCalc)
' Helpers:-
Dim Cell As Range
Dim R As Long
Set WsComp = Sheets("Components Data")
Set WsCalc = Sheets("Calculator")
WsCalc.Unprotect Password:="secret"
Application.ScreenUpdating = False
'//Get the index of the last filled row based on column A
With WsComp
' observe the leading period in ".Rows.Count"
'LastComponentRowIndex = .Cells(.Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
'Set CompRng = .Range("A2:A" & LastComponentRowIndex)
' avoids the need for decalring LastComponentRowIndex
Set CompRng = .Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))
End With
With WsCalc
' set a range of all criteria to look up
Set CalcRng = .Range(.Cells(1, "D"), _
.Cells(1, .Columns.Count).End(xlToLeft))
'//Get the index of the last non-empty row in column B
' loop through all rows in WsCalc
For R = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
If Val(.Cells(R, "B").Value) Then ' presumed to be a week number
'//Loop through all audit criteria
For Each Cell In CalcRng
With .Cells(R, Cell.Column)
.Value = WorksheetFunction.CountIfs( _
CompRng, Cell.Value, _
CompRng.Offset(0, 1), WsCalc.Cells(R, "B").Value)
.NumberFormat = "0;-0;;" ' suppress display of zero
End With
Next Cell
End If
.Cells(R, "C").Value = WorksheetFunction.Sum(CalcRng.Offset(R - 1))
Next R
End With
Application.ScreenUpdating = True
End Sub
Frankly, I couldn't understand all of your intentions. I presumed that column B in your Calculations sheet would contain a week number and that this week number would also be found in the Components Data (in column B). If so, you would be counting the occurrences of each component by week, and that is what I programmed.
I think it doesn't matter if I got that part wrong. Your main question was how to look up each of the Components in Calculations!D1:??. That method is very well demonstrated in my above answer and I feel confident you will be able to transplant the useful bits to your own project. Good luck!
I suggest taking a look at VBA dictionaries. In this case, you could store each component as a key and for the value you can accumulate the number of occurrences of the component for a given week.
I don't have a VBA editor available on my computer at the moment to test this, but it would likely look something along the lines of what I've got below. Also, I'll admit that I may not have fully understood the layout of your sheets, but the general principle here will definitely apply.
For a pretty full overview of dictionaries in VBA, here's a good resource that'd I'd recommend: https://excelmacromastery.com/vba-dictionary/
Public Sub CountComponent()
Application.ScreenUpdating = False
Sheets("Calculator").Unprotect Password:="secret"
Set wsComponentData = Sheets("Components Data")
Set wsCalculator = Sheets("Calculator")
'//Get the index of the last filled row based on column A
LastComponentRowIndex = wsComponentData.Cells(Rows.Count, "A").End(xlUp).Row
'//Get Range for ComponentData
Set ComponentRange = wsComponentData.Range("A2:A" & LastComponentRowIndex)
'//Get the index of the last filled row based on column C
LasttotalauditRowIndex = wsCalculator.Cells(Rows.Count, "C").End(xlUp).Row
'//Get range for Calculator
Set MyRange = wsCalculator.Range("C2:C" & LasttotalauditRowIndex)
TotalCalls = WorksheetFunction.Sum(MyRange)
'// Declare a new dictionary
dim componentDict as New Scripting.Dictionary
'// First loop through the Calculator sheet to get each component
'// and set initial value to zero
dim i as Long, lastCalcColumn as Long
lastCalcColumn = wsCalculator.Cells(1, Columns.count).end(xlToLeft).Column
for i = 4 to lastCalcColumn
'// Adding each item to dictionary, a couple of ways to write this,
'// but this is probably the easiest
componentDict(wsCalculator.Cells(i, 1).Value) = 0
next i
'//Looping through all filled rows in the Components Data sheet
'// I changed this to loop through each row in your component sheet
'// So that we can accumulate the total occurences
dim current_key as String
For i = 2 To LastComponentRowIndex
If wsComponentData.Range("G" & i).Value <> "" Then
'// assuming component names are in the "G" column
'// change this as needed
current_key = wsComponentData.Range("G" & i).Value
componentDict(current_key) = componentDict(current_key) + 1
end if
Next i
'// now back to the Calculator sheet to enter the values
for i = 4 to lastCalcColumn
current_key = wsCalculator.Cells(i, 1).Value
wsCalculator.Cells(i, 2).Value = componentDict(current_key)
next i
End Sub

Copying rows to a wksheet based on the value in a specific column isn't applying to my whole spreadsheet

I'm looping over values in Column B of the current worksheet. If the value's length is 8 characters, copy the WHOLE row to another sheet.
It is kind of working, but I'm missing around a hundred rows that should have been copied.
I guess it's to do with the format of the cell values in Column B. There are some that are just Text headers which will definitely not meet the criteria. The ones that it should copy are all in this format (Column B):
6008571X
60088242
....
The rows I'm interested in have 8 characters in Column B. The problem is that some of them might be formatted as numbers some as text (or perhaps preceded by ').
Sub aims()
Dim i As Long
'Get the address of the first non blank cell in Row B from the bottom
MyFirstBlankAddress = Range("B1048576").End(xlUp).Offset(1, 0).Address
'Extract the number from the address to get the row number
MyRowNumber = Split(MyFirstBlankAddress, "$")(2)
For i = 1 To MyRowNumber
With Range("B" & i)
If Len(.Value) = 8 Then .EntireRow.Copy Destination:=Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End With
Next i
End Sub
I was expecting 410 rows copied, while only 276 got copied.
EDIT: I have been reading your answers/suggestions and testing stuff. I've found out that the problem lies elsewhere. My original code identifies the rows in a correct way, it's something to do with copying.
If I change my code to just highlight the matching rows, it matches all the right rows:
If Len(.Value) = 8 Then .EntireRow.Interior.Color = 5296274
I'm sure there is a better way to do the copy/paste, which is where your issue is, but the below works.
Sub aims()
Dim i As Long
Dim vLastRow As Long
Dim s2 As Long
'find last row in sheet, or you could change to find last row in specified column
'Example: Cells = Columns(column number or letter), Cells(1, 1) = Cells(1, column number)
vLastRow = Cells.Find(what:="*", after:=Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row
s2 = 1
Application.ScreenUpdating = False
For i = 1 To vLastRow
If Trim(Len(CStr(Cells(i, 2)))) = 8 Then
Rows(i).EntireRow.Copy Destination:=Sheets(2).Range(Cells(s2, 1).Address)
s2 = s2 + 1
End If
Next i
Application.ScreenUpdating = True
End Sub
You can try something like this. The below code attempts to copy everything at once instead of having many instances of copy/paste. The two tests are seeing if the trimmed value has a character length of 8 OR if the trimmed value has a character length of 9 but the last character is the apostrophe. If either of these criteria are met, we will add that cell to a Union.
Once the code has looped through all rows, it will copy the entire union at all once
Option Explicit
Sub shooter()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") '<-- Update
Dim LR As Long, i As Long, Add As Boolean, CopyMe As Range
Dim x As Range
LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row
For Each x In ws.Range("B2:B" & LR)
Add = False
If Len(Trim(x)) = 8 Then
Add = True
ElseIf Len(Trim(x)) = 9 And Right(Trim(x), 1) = "'" Then
Add = True
End If
If Add Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, x)
Else
Set CopyMe = x
End If
End If
Next x
If Not CopyMe Is Nothing Then
CopyMe.EntireRow.Copy Destination:=Sheets(2).Range(“A1”)
End If
End Sub

Excel spreadsheet checking which row contains contains data

I have a vb.net application from which I open an excel spreadsheet that contains data. I copy all the data and insert it into sql server. I'm coming across a small issue with finding the last row. Here's how I've been doing it right now...
Dim lastRow As Long = 0
lastRow = xlws.Cells.SpecialCells(XlCellType.xlCellTypeLastCell, Type.Missing).Row
This finds the last row for me but often times, the spreadsheet might contain data that is not relevant to what I'm trying to insert into my table - in this case it's a confidentiality statement at the last row of the spreadsheet. So what i'm trying to do is set the last row to whatever the last row of ACTUAL data is. This is what it looks like...
So in this case - i want the last row to be recognized to be row 11 rather than row 13. The thing is - the formatting of the report might be slightly different (for the confidentiality statement) so often times it might start in column A or B and be merged (possibly) or they might write it elsewhere.
Another thing is that Column A and B of data (ending at row 11) might sometimes not have a value. How should I go about something like this?
EDIT:
This is what I'm coming up with - Hate GoTo's but....
LastRowCheck:
If CStr(excel.Cells(lastRow, 4).Value) = "" And CStr(excel.Cells(lastRow, 5).value) = "" And CStr(excel.Cells(lastRow, 6).value) = "" Then
lastRow += -1
goto LastRowCheck
End If
How about:
Sub TheTrueLastRow()
Dim i As Long
For i = 1 To Rows.Count
If Cells(i, "B").Value = "" Or Cells(i, "E").Value = "" Then
lastRow = i - 1
Exit For
End If
Next i
MsgBox lastRow
End Sub
Maybe something like this:
Sub Test()
MsgBox LastRow(ThisWorkbook.Worksheets(2))
End Sub
Public Function LastRow(wrkSht As Worksheet) As Long
Dim rLastCell As Range
Dim lLastCol As Long, lLastRow As Long
Dim rCol As Range
On Error Resume Next
With wrkSht
lLastCol = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
lLastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
If lLastCol = 0 Then lLastCol = 1
If lLastRow = 0 Then lLastRow = 1
Set rLastCell = .Cells(lLastRow, lLastCol)
'Look at each column, if the last cell is merged then look up from there,
'otherwise leave the last row as it is.
For Each rCol In .Range(.Cells(rLastCell.Row, 1), rLastCell).Columns
If rCol.MergeCells Then
LastRow = rCol.End(xlUp).Row
Exit For
Else
LastRow = rLastCell.Row
End If
Next rCol
End With
On Error GoTo 0
End Function
Edit: Just noticed, it will fail at this point (well, if the last column is shorter rather than the first two).
Another thing is that Column A and B of data (ending at row 11) might
sometimes not have a value. How should I go about something like this?
If you have a column that has data in each row of the table and the there is an empty cell between that on wanted data
xlws.Range("B1").End(Excel.XlDirection.xlDown).Row
Alternately, you can take the bottom up approach if the only there is no unwanted data at the end of a column.
xlws.Range("B" & xlws.Rows.Count).End(Excel.XlDirection.xlUp).Row

Find last row in range

I'm having a little trouble with finding the last row.
What I am trying to do is find the last row in column "A", then use that to find the last row within a range.
Example of Data:
1) LR_wbSelect = wbshtSelect.cells(Rows.count, "A").End(xlUp).Row - 22
2) LR_wbSelectNew = wbshtSelect.cells(LR_wbSelect, "A").End(xlUp).Row
I am using the last row in column "A" as the data from row 29 down will always be the same length, the rows used in column "B" from row 29 can be a varying number of rows.
So I am trying to use LR_wbSelect in column "A" to get my starting last Row, then within LR_wbSelectNew using it as the starting point to look up from.
This works when the column I set to "A", LR_wbSelectNew gives me the row of "17", but when I change the column in LR_wbSelectNew to "B" it doesn't give the correct last row of "18".
I can change the column to "C, D, E, F" and the code works fine, but the only column that I can use is "B" because it will always have data in it, where the rest of that row could have a blank cell.
After doing some testing on the sheet, by pressing CRTL & Up from the lastring point of LR_wbSelect column "B" ignores the data in the rows and go to the row where it find data. I can't see a reason why Excel doesn't think there is data in these cells?
There are mulitple results and methods when searching for the LastRow (in Column B).
When using Cells(.Rows.Count, "B").End(xlUp).Row you will get the last row with data in Column B (it ignores rows with spaces, and goes all the way down).
When using:
With wbshtSelect.Range("B10").CurrentRegion
LR_wbSelectNew = .Rows(.Rows.Count).Row
End With
You are searching for the last row with data in Column B of the CurrentRegion, that starts from cell B10, untill the first line without data (it stops on the first row with empty row).
Full Code:
Sub GetLastRow()
Dim wbshtSelect As Worksheet
Dim LR_wbSelectNew As Long
' modify "Sheet2" to your sheet's name
Set wbshtSelect = Sheets("Sheet2")
' find last row with data in Column B
With wbshtSelect
LR_wbSelectNew = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
' for debug only
Debug.Print LR_wbSelectNew ' >>result 31
' find last row with data in Column B at current regioun starting at cell B10
With wbshtSelect.Range("B10").CurrentRegion
LR_wbSelectNew = .Rows(.Rows.Count).Row
End With
' for debug only
Debug.Print LR_wbSelectNew ' >> result 18
End Sub
Edit1: code searches for last row for cells with values (it ignores blank cells with formulas inside).
Sub GetLastRow()
Dim wbshtSelect As Worksheet
Dim LR_wbSelectNew As Long
' modify "Sheet2" to your sheet's name
Set wbshtSelect = Sheets("Sheet2")
' find last row with data in Column B at current regioun starting at cell B10
With wbshtSelect.Range("B10").CurrentRegion
LR_wbSelectNew = .Rows(.Rows.Count).Row
End With
Dim Rng As Range
Set Rng = wbshtSelect.Range("B10:B" & LR_wbSelectNew)
' find last row inside the range, ignore values inside formulas
LR_wbSelectNew = Rng.Find(What:="*", _
After:=Range("B10"), _
LookAt:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
' for debug
Debug.Print LR_wbSelectNew ' << result 18 (with formulas in the range)
End Sub
Hope this piece of code helps !
Sub LastRowInOneColumn()
'Find the last used row in a Column: column A in this example
Dim LastRow As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
MsgBox LastRow
End Sub
I came here looking for a way to find the last row in a non-contiguous range. Most responses here only check one column at a time so I created a few different functions to solve this problem. I will admit, though, that my .Find() implementation is essentially the same as Shai Rado's answer.
Implementation 1 - Uses Range().Find() in reverse order
Function LastRowInRange_Find(ByVal rng As Range) As Long
'searches range from bottom up stopping when it finds anything (*)
Dim rngFind As Range
Set rngFind = rng.Find( What:="*", _
After:=rng.Parent.Cells(rng.row, rng.Column), _
LookAt:=xlWhole, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If Not rngFind Is Nothing Then
LastRowInRange_Find = rngFind.row
Else
LastRowInRange_Find = rng.row
End If
End Function
Implementation 2 - Uses Range().End(xlUp) on each column
Function LastRowInRange_xlUp(ByVal rng As Range) As Long
Dim lastRowCurrent As Long
Dim lastRowBest As Long
'loop through columns in range
Dim i As Long
For i = rng.Column To rng.Column + rng.Columns.count - 1
If rng.Rows.count < Rows.count Then
lastRowCurrent = Cells(rng.row + rng.Rows.count, i).End(xlUp).row
Else
lastRowCurrent = Cells(rng.Rows.count, i).End(xlUp).row
End If
If lastRowCurrent > lastRowBest Then
lastRowBest = lastRowCurrent
End If
Next i
If lastRowBest < rng.row Then
LastRowInRange_xlUp = rng.row
Else
LastRowInRange_xlUp = lastRowBest
End If
End Function
Implementation 3 - Loops through an Array in reverse order
Function LastRowInRange_Array(ByVal rng As Range) As Long
'store range's data as an array
Dim rngValues As Variant
rngValues = rng.Value2
Dim lastRow As Long
Dim i As Long
Dim j As Long
'loop through range from left to right and from bottom upwards
For i = LBound(rngValues, 2) To UBound(rngValues, 2) 'columns
For j = UBound(rngValues, 1) To LBound(rngValues, 1) Step -1 'rows
'if cell is not empty
If Len(Trim(rngValues(j, i))) > 0 Then
If j > lastRow Then lastRow = j
Exit For
End If
Next j
Next i
If lastRow = 0 Then
LastRowInRange_Array = rng.row
Else
LastRowInRange_Array = lastRow + rng.row - 1
End If
End Function
I have not tested which of these implementations works fastest on large sets of data, but I would imagine that the winner would be _Array since it is not looping through each cell on the sheet individually but instead loops through the data stored in memory. However, I have included all 3 for variety :)
How to use
To use these functions, you drop them into your code sheet/module, specify a range as their parameter, and then they will return the "lowest" filled row within that range.
Here's how you can use any of them to solve the initial problem that was asked:
Sub answer()
Dim testRange As Range
Set testRange = Range("A1:F28")
MsgBox LastRowInRange_Find(testRange)
MsgBox LastRowInRange_xlUp(testRange)
MsgBox LastRowInRange_Array(testRange)
End Sub
Each of these will return 18.
If your wbshtSelect is defined as worksheet and you have used set to define the specific worksheet, you can use this.
Dim LastRow As Long
wbshtSelect.UsedRange ' Refresh UsedRange
LastRow = wbshtSelect.UsedRange.Rows(wbshtSelect.UsedRange.Rows.Count).Row
Otherwise take a look here http://www.ozgrid.com/VBA/ExcelRanges.htm
LR_wbSelectNew = wbshtSelect.cells(LR_wbSelect, "B").End(xlUp).Row
Why are you using "LR_wbSelect" as the row counter? If you want to know the last row of column 'B', you should use Rows.count
Rows.count --> Returns maximum number of rows (which is 1048576 for Excel 2007 and up)
End(xlUp) --> Moves the pointer upward to the last used row
So,
cells(Rows.count, "A").End(xlUp).Row --> This moves the pointer to the last row if the column 'A' (as if you are pressing Crtl+Up keys when A1048576 cell is selected)
So, use Rows.count to select the last row for column 'B' as well. If you have some specific requirement related to LR_wbSelect, please mention it.
Alternatively, if you want to know the last row used in a sheet, you may use the below:
mySheet.Cells.SpecialCells(xlCellTypeLastCell).Row
LR_wbSelect = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Simple function that return last row no. in specific sheet.
It takes the last address in UsedRange and retrieve last row number.
Feel to free change the code and use standard range insead of UsedRange.
Function FindLastRow(wsToCheck As Worksheet) As Long
Dim str As String
str = wsToCheck.UsedRange.AddressLocal()
FindLastRow = Right(str, InStr(1, StrReverse(str), "$") - 1)
End Function
Range().End will bring you to the end of a code block. If the starting cell is empty, it brings you the the first used cell or the last cell. It the cells is not empty it brings you to the last used cell. For this reason, you need to test whether or not the cell in column B is to determine whether to use LR_wbSelectNew as the last row.
With wbshtSelect
LR_wbSelect = .Cells(Rows.Count, "A").End(xlUp).Row - 22
If .Cells(LR_wbSelect, "B") <> "" Then
LR_wbSelectNew = LR_wbSelect
Else
LR_wbSelectNew = .Cells(LR_wbSelect, "B").End(xlUp).Row
End If
End With
This code defines a Target range that extends from A1 to the last row in column a - 22 and extends 10 columns.
Dim Target As Range
With wbshtSelect
Set Target = .Range("A1", .Cells(Rows.Count, "A").End(xlUp).Offset(-22)).Resize(, 10)
End With
'This is sure method to find or catch last row in any column even 'if some cell are blank in-between. (Excel-2007)`
'This works even if sheet is not active
'mycol is the column you want to get last row number
for n=1048575 to 1 step -1
myval=cells(n,mycol)
if myval<>"" then
mylastrow=n 'this is last row in the column
exit for
end if
next
ret=msgbox("Last row in column-" & mycol & "is=" & mylastrow)
Dim rng As Range
Dim FirstRow, LastRow As long
Set rng = Selection
With rng
FirstRow = ActiveCell.Row
LastRow = .Rows(.Rows.Count).Row
End With
Shai Rado's first solution is a great one, but for some it might need a bit more elaboration:
Dim rngCurr, lastRow
rngCurr = wbshtSelect.Range("B10").CurrentRegion
lastRow = rngCurr.Rows(rngCurr.Rows.Count).Row
If you want to know the last used row in the entire worksheet:
Dim rngCurr, lastRow
rngCurr = Range("A1").CurrentRegion
lastRow = rngCurr.Rows(rngCurr.Rows.Count).Row
Backing off from the range to the worksheet will get you the whole sheet extents of the range used on the sheet (which may be smaller than you expect if the sheet doesn't have data in the top rows; but it does include internal blanks)
TheRange.Worksheet.UsedRange.Rows.Count
If there is no data in the top rows, the following will get you the first row which you need to add to the above to get the highest row number
TheRange.End(xlDown).Row
So
Dim TheRange as Range
Dim MaxRow as Long
MaxRow = TheRange.Worksheet.UsedRange.Rows.Count + TheRange.End(xlDown).Row
Will get the highest row number with data (but not the whole sheet)
Before getting into complex coding why not build something on the below principle:
MaxRow = Application.Evaluate("MIN(ROW(A10:C29)) + ROWS(A10:C29) - 1")

Fill an array with rows that do not meet specific criteria and preserve hyperlink formulas

I have a sheet with 32 columns of data, starting in row 2 to LastRow. The first row is a header row. Several columns contain hyperlink formulas (“D”,”F”,”R”,”S”,”X”,”Z” and “AA”), other columns contain general values. I would like to populate an array with rows that don’t include specific values in column D. Those values are part of a hyperlink formula. For example, in D3 there is =HYPERLINK("http://www.uniprot.org/uniprot/P35222"," CTNNB1"), I’m filtering based on the values inside the second set of quotation marks “CTNNB1”. I would like to output this array on a new sheet. The code bellow runs but it doesn’t output any data. The code includes comments to explain steps and issues. Please help me fix the code or suggest something that will work. Thank you very much in advance.
Once the rows that meet the criteria are identified, how do I create an array row by row and how to correctly output it on a Sheet “Access”?
Sub aa()
Dim CellValue As Variant
Dim CellFormula As String
Dim CellPart() As String
Dim CellValueRow As Long
Dim CellValueCol As Long
Dim ColCrnt As Long
Dim ColLast As Long
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("all") ' Replaced with name of your worksheet
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
ReDim CellValue(1 To RowLast - 1, 1 To ColLast) 'max # of array rows based on last row of data available
CellValueRow = 1
For RowCrnt = 2 To RowLast
CellFormula = .Cells(RowCrnt, "D").Formula
If Left(CellFormula, 11) = "=HYPERLINK(" Then
CellFormula = Mid(CellFormula, 12) '=> "http://www.uniprot.org/uniprot/P42336","PIK3CA")
CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1) '=> "http://www.uniprot.org/uniprot/P42336","PIK3CA"
CellFormula = Replace(CellFormula, """", "") '=> http://www.uniprot.org/uniprot/P42336,PIK3CA
CellPart = Split(CellFormula, ",")
'Debug.Print CellPart(0) & " " & CellPart(1)
If CellPart(1) <> "Q61R" And CellPart(1) <> "I391M" And CellPart(1) <> "V600E" And _
CellPart(1) <> "PIC3CA" And CellPart(1) <> "BRAF" And CellPart(1) <> "EGFR" Then
CellValue(CellValueRow, ) = .Range(.Cells(RowCrnt, 1), .Cells(RowCrnt, ColLast)).Formula '===> need help here
CellValueRow = CellValueRow + 1
End If
End If
Next
'For RowCrnt = 1 To 10
'For ColCrnt = 1 To 10
'Debug.Print "[R" & RowCrnt & "C" & ColCrnt & "]" & CellValue(RowCrnt, ColCrnt);
'Next
'Debug.Print
'Next
End With
Worksheets("Access").Range("A2:AF" & RowLast).Value = Application.Index(CellValue, 0)
End Sub
Issue 1
Dim i, j, k, m, LastRow, openPos, closePos As Integer 'As Long
This declares i, j, k to openPos as Variants and only closePos as an Integer, If you list several variables in one Dim statement, you must give each one its own type.
Do not use type Integer. With VBA, “Integer” declares a 16-bit integer which requires special processing on 32-bit or 64-bit computers. Long is now the recommended type.
I rarely place several variables in a single Dim statement. It saves a little typing but I prefer to declare my variables one per line in alphabetic sequence.
Please do not declare variables with names like i, j and k. If this is a “quick write” macro that will then be discarded, names probably do not matter too much. However, if you might return to this macro in six months, will you remember what i, j and k are? Meaningful names take longer to type but make your code so much easier to read and understand.
Issue 2
With ActiveSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
The active worksheet is the default worksheet so specifying its use does not serve much purpose.
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
would give exactly the same effect.
However I would prefer you write With Worksheets(“xxxx”). If you use the active worksheet, you are relying on the user having the required worksheet open when they start the macro. If you return to this macro in six months, will you remember which worksheet is the required worksheet? Sheets.Add makes the new sheet the active worksheet. Your code can get very confusing if you have to remember which sheet is the active sheet.
Issue 3
ReDim Result(LastRow - 1)
The format for subscripts is: [Lower To] Upper.
If you omit “[Lower To]”, the value of the Option Base statement determines the value of the lower bound. I do not recall ever seeing the Option Base statement but I still prefer being explicit. VBA is unusual in allowing you to have different lower bounds; for most languages it is fixed as zero. With VBA I can write: ReDim Result(2 To LastRow). I always set my lower bounds to what every value I find most helpful at the time.
If VBA creates an array (for example with Split), that array will almost always have a lower bound of zero. The only exception I can think of is when you copy a range to a Variant. Here the resultant array has lower bounds of one.
You set Result to one dimension but use it as two dimensional array. I think you want:
ReDim Result(1 To LastRow-1, 1 To 27)
Issue 4
On Error Resume Next
You should only use this statement like this:
On Error Resume Next
Statement that might fail
On Error GoTo 0
If Err.Number > 0 Then
Test or display Err.Number or Err.Description
End If
You should only use On Error when you cannot avoid Excel encountering an error. For example, when opening a file for which you might not have read permission. In this situation, On Error allows you to provide the user with a helpful message or perhaps recover by trying a different file. You do not use it to avoid arithmetic errors.
Issue 5
If Application.ReferenceStyle = xlR1C1 Then
Str = .Cells(i, 4).FormulaR1C1
Else
Str = .Cells(i, 4).Formula
End If
Application.ReferenceStyle affects how formulae are displayed. A VBA macro can request either style. Pick the formula style you prefer although a hyperlink should not be affected by your choice.
Issue 6
Before you can extract the display text from a hyperlink formula you must check the cell contains a hyperlink formula. This macro uses a different technique although there is nothing wrong with searching for the last two double quotes in the formula. With this technique, the value you seek is in CellPart(1).
Option Explicit
Sub Demo()
Dim CellFormula As String
Dim CellPart() As String
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("Data") ‘ Replace with the name of your worksheet
RowLast = .Cells(Rows.Count, "D").End(xlUp).Row
For RowCrnt = 2 To RowLast
CellFormula = .Cells(RowCrnt, "D").Formula
If Left(CellFormula, 11) = "=HYPERLINK(" Then
' It is possible to make all these changes to CellFormula in one go
' but this is better for showing what I am doing
CellFormula = Mid(CellFormula, 12)
CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1)
CellFormula = Replace(CellFormula, """", "")
CellPart = Split(CellFormula, ",")
Debug.Print CellPart(0) & " " & CellPart(1)
End If
Next
End With
End Sub
**Issue 7 **
In your macro you are:
Scanning down column D looking for rows of interest.
Copying the cells of rows of interest to an array.
You do nothing with the final array but I assume you intended to write it to the new worksheet.
This technique involves moving every cell of interest individually from the worksheet to the array. This is not quite as slow as some people think but it is not in my view the easiest approach.
You have used LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row to find the last row containing data. VBA offers several methods of finding the last row and column and this is generally the easiest to use. However, none of the available methods works in every situation. This technique relies on the programmer knowing which column (or row) contains the most data.
I have used:
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
The first statement finds the last used cell in any column while the second finds the last used cell in any row. These statements do not rely on the programmer knowing which column has the last row or which row has the last column. They are also useful if your data is not rectangular.
In this macro, I have pulled every formula from every cell in the worksheet into an array in a single statement. I have then displayed the first ten rows and columns so you can see what I have imported.
Sub Demo2()
Dim CellValue As Variant
Dim ColCrnt As Long
Dim ColLast As Long
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("Data") ' Replace with the name of your worksheet
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByColumns, xlPrevious).Column
CellValue = .Range(.Cells(1, 1), .Cells(RowLast, ColLast)).Formula
For RowCrnt = 1 To 10
For ColCrnt = 1 To 10
Debug.Print "[R" & RowCrnt & "C" & ColCrnt & "]" & CellValue(RowCrnt, ColCrnt);
Next
Debug.Print
Next
End With
End Sub
You may need to increase my end values of 10 to see enough data but this macro demonstrates that I can download every value and formula in a worksheet into an array with a single statement.
I recommend creating little macros like mine that explore a single feature when you are unsure about that feature. The trouble with your complete macro is that you do not know where it has gone wrong. With a single feature macro there is nothing else to confuse the picture as you try different things you get it working. If you fail to get it working, a single feature macro will get an answer on Stack Overflow much more quickly than a confused, multi-feature macro.
Complete solution
Above I have explored how to access the data and how to make decisions about which rows are of interest. I think we are now ready to make final decisions.
There are several approaches and it is not obvious to me which would be the better.
For step 1, I believe importing the worksheet into an array and identifying interesting rows in memory is the best approach. The alternative, reading down column D within the worksheet, has no advantages that I can see.
For step 2, I can see three different approaches with a minor different to step 1:
Copy the entire worksheet to an array. Copy interesting rows to a different array. Copy the second array to a new worksheet.
Copy column D of the worksheet to an array. Use the array to identify interesting rows. Copy the interesting rows, as they are identified, from the original worksheet to a new worksheet.
Copy column D of the worksheet to an array. Use the array to identify interesting rows. Use Union to a single range containing all the interesting rows and copy them as a unit from the original worksheet to a new worksheet.
I have never tried approach 3 although I have done something similar by using AutoFilter to select rows and then copying the visible rows to a new location. However, I do not see that it offers anything over approach 2 and I have had problems with very large unions so I have ignored approach 3.
You can only copy values and formulae to an array so you will lose any formatting with approach 1. Approach 1 is probably faster than approach 2. Approach 2 looks as though it will be a little simpler to code.
Apart from the possible need to preserve formatting, I cannot see a major advantage for either approach. Since formatting might be important for this or a similar project, I have decided to go for approach 2.
It is not relevant for approach 2, but you say you do not know how to ReDim Preserve Result to remove the unused rows. The answer is you cannot remove these rows conveniently but it does not matter. You can only use ReDim Preserve to change the size of the last dimension of an array. An array read from a worksheet or being prepared for writing to a worksheet has the worksheet columns as the second dimension. You could use the worksheet function Transpose to switch the dimensions, ReDim the array and then Transpose back. However, I have found that some (perhaps all) worksheet functions are very slow. A transpose coded in VBA is faster than the Excel version. The worksheet functions seem perfectly adequate when called from the keyboard, so the slowness is probably an overhead of the interface. However, when writing an array to a worksheet, unused trailing rows do not matter except possibly if they might overwrite rows you wish to keep.
The following is my attempt at your macro. I do not have much suitable test data but it appears to work as required.
Sub NewAa()
' Change these names as required
Const WshtSrcName As String = "Data"
Const WshtExtName As String = "Extract"
Dim CellFormula As String
Dim CellPart() As String
Dim CellValue As Variant
Dim Found As Boolean
Dim InxNTBE
Dim NotToBeExtracted() As Variant
Dim RowExtCrnt As Long
Dim RowSrcCrnt As Long
Dim RowSrcLast As Long
Dim WshtSrc As Worksheet
Dim WshtExt As Worksheet
' If you are going to be extracting different hyperlinks, an array is easier
' to amend than an If statement
NotToBeExtracted = Array("Q61R", "I391M", "V600E", "PIC3CA", "BRAF", "EGFR")
Set WshtSrc = Worksheets(WshtSrcName)
Worksheets.Add After:=Worksheets(Worksheets.Count)
' The new worksheet is now the active worksheet
ActiveSheet.Name = WshtExtName
Set WshtExt = ActiveSheet
With WshtSrc
RowSrcLast = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious).Row
' Import column D
CellValue = .Range(.Cells(1, "D"), .Cells(RowSrcLast, "D")).Formula
' CellValue will be an array with dimensions (1 To RowLast, 1 to 1).
' Note the lower bounds for such arrays are always one even when column 4 has been imported.
End With
' Copy header row
WshtSrc.Rows(1).Copy Destination:=WshtExt.Cells(1, 1)
' Note the format of copy range is: Xxxxx.Copy Destination:=Yyyyy
' where:
' Xxxxx is the range to be copied
' Yyyyy is the top left cell of the destination range
' "Destination:=" is optional but think it add clarity.
RowExtCrnt = 2
For RowSrcCrnt = 2 To RowSrcLast
CellFormula = CellValue(RowSrcCrnt, 1)
If Left(CellFormula, 11) = "=HYPERLINK(" Then
' Format is: =HYPERLINK("Xxxx","Yyyy")
' Extract Yyyy to CellPart(1)
CellFormula = Mid(CellFormula, 12)
CellFormula = Mid(CellFormula, 1, Len(CellFormula) - 1)
CellFormula = Replace(CellFormula, """", "")
CellPart = Split(CellFormula, ",")
' Attempt to match CellFormula against one of the hyperlink texts
' that are not to be extracted
Found = False
For InxNTBE = LBound(NotToBeExtracted) To UBound(NotToBeExtracted)
If CellPart(1) = NotToBeExtracted(InxNTBE) Then
Found = True
Exit For
End If
Next
If Not Found Then
' This hyperlink is to be extarcted
WshtSrc.Rows(RowSrcCrnt).Copy Destination:=WshtExt.Cells(RowExtCrnt, 1)
RowExtCrnt = RowExtCrnt + 1
End If
End If
Next
End Sub

Resources