Finding the LastRow in multiple column ranges? - vba

I'm trying to find the LastRow in multiple column ranges ignoring certain columns... I have two attempts but can't get either working correctly:
BOTH Examples are ignoring columns N and O
My first attempt is the following, however it doesn't get the correct last range, if I have something in A15 for example and T10, it thinks the last row is 10 when it should be 15.
Sub LastRowMacro()
LastRowString = "A1:M" & Rows.Count & ", P1:Z" & Rows.Count
LastRowTest = Range(LastRowString).Find(What:="*", After:=[A1], SearchOrder:=xlByRows, searchDirection:=xlPrevious).Row
End Sub
My second attempt is as follows, but it seems rather long winded.
Sub LastRowMacro()
Dim i As Long
LastRow = 1
IgnoreColumnList = "N;O"
For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
ColumnLetter = Split(Cells(1, i).Address(True, False), "$")(0)
For Each varFind In Split(IgnoreColumnList, ";")
If varFind = ColumnLetter Then
varNotFound = False
Exit For
End If
varNotFound = True
Next
If varNotFound Then
CurrentLastRow = Cells(Rows.Count, i).End(xlUp).Row
If CurrentLastRow >= LastRow Then
LastRow = CurrentLastRow
End If
varNotFound = False
End If
Next
End Sub
Ideally I'd like my first attempt to work however if it just doesn't work then someone surely can improve my second version...

Try this
*There is an ignoreList variable with all the columns that you want to ignore. Make sure you populate this correctly - currently ignoring N, O, P
*You may need to set the sh variable to the correct sheet - currently it's Sheet1
*btw. this snippet will always find the last last row on the spreadsheet. you can add another elseif to check whether there are 2 columns with the same high last row in case there was 2 columns with the highest lastRows.
Sub FindingLastRow() ' ignoring some columns
Dim ignoreList
ignoreList = Array("N", "O", "P") ' MODIFY IGNORE LIST
Dim sh As Worksheet
Set sh = Sheet1 ' SET CORRECT SHEET
Dim currentlast As Range
Set currentlast = sh.Cells(1, 1)
Dim iteratingCell As Range
With sh
For j = 1 To .UsedRange.Columns.Count
Set iteratingCell = .Cells(1, j)
If Not isIgnored(iteratingCell, ignoreList) Then
If iteratingCell.Cells(Rows.Count).End(xlUp).Row >= currentlast.Cells(Rows.Count).End(xlUp).Row Then
Set currentlast = iteratingCell
End If
End If
Next
Set currentlast = .Range("$" & Split(currentlast.Address, "$")(1) & "$" & currentlast.Cells(Rows.Count).End(xlUp).Row)
End With
MsgBox currentlast.Address
End Sub
Function isIgnored(currentlast As Range, ignoreList As Variant) As Boolean
Dim ignore As Boolean
Dim letter As Variant
For Each letter In ignoreList
If StrComp(Split(currentlast.Address, "$")(1), letter, vbTextCompare) = 0 Then
ignore = True
Exit For
End If
Next
isIgnored = ignore
End Function

Related

Excel vba to select next option in autofilter drop down menu

I have several column with a few hundred rows of data. One of my roles is to look through the data (most commonly in column 2), So what I do is click the little drop down arrow on the column header to open the auto filter list, deselects the first value, then select the next value. Then, likewise, open menu, deselect second value and select third.
There's no fixed number of values either. Different data sheets have varying amounts of data. The data usually goes like 0,10,40,50,60,.... Again it isn't fixed. It is an array however. All the data is in increasing order already.
What I need:
Preferably a button to click (for column 2) that deselects the currently selected value, selects the next value and filters that out
The converse. I.e. Deselects the current value, selects the previous value
Essentially I need a Forward and Back button for my data.
This is what I get when I tried to record my actions.
Sub a()
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:
="750385/000"
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:
="750385/010"
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:
="750385/017"
End Sub
Appreciate any help!!
There is a method to read out the curent filter, from which on you can loop through the column untill you find that value. here you just need to jump to the value in the next row, which now you can put into the filter.
So in conclusion this method would be your "forward"-button
Sub test()
Dim startRow As Integer
startRow = 2
Dim rangeString As String
rangeString = "$A$2:$V$609"
Dim rng As Range
Set rng = Range(rangeString)
Dim currentCrit As String
currentCrit = rng.Parent.AutoFilter.Filters(2).Criteria1
currentCrit = Right(currentCrit, Len(currentCrit) - 1)
Dim i As Integer
For i = startRow To startRow + rng.Rows.Count
If Cells(i, 2).Value = currentCrit Then
i = i + 1
Exit For
End If
Next
If i > rng.Rows.Count + startRow Then
Exit Sub
End If
ActiveSheet.Range(rangeString).AutoFilter Field:=2, Criteria1:=Cells(i, 2).Value
End Sub
Note: This won´t work if there are duplicates in you column B, if this is so replace the part with the For-Loop with the following:
Dim i As Integer
Dim bool As Boolean
bool = False
For i = startRow To startRow + rng.Rows.Count
If Cells(i, 2).Value = currentCrit Then
bool = True
End If
If bool And Cells(i, 2).Value <> currentCrit Then
Exit For
End If
Next
Hope I could help.
I would use Spinbuttons on the sheet and link them to the first cell of the column, it want to filter.
(I called it spbFilterChange and linked it to $B$1)
(picture upload doesnt work here, sorry)
Then you can put the following code in the module of your worksheet:
Private Sub spbFilterChange_SpinDown()
Change_Filter Me.Range(Me.spbFilterChange.LinkedCell), False
End Sub
Private Sub spbFilterChange_SpinUp()
Change_Filter Me.Range(Me.spbFilterChange.LinkedCell), True
End Sub
And the following sub in a standard module:
Option Explicit
Sub Change_Filter(SortField As Range, Up As Boolean)
Dim Filter_Values As Collection
Dim Value_Arr, Val, Sort_Value As String
Application.ScreenUpdating = False
' Find Unique Values in relevant Column -> Collection
Set Filter_Values = New Collection
SortField.Offset(2, 0).Areas(1).AutoFilter SortField.Column
Value_Arr = SortField.Parent.Range(SortField.Offset(3, 0), SortField.Parent.Cells(SortField.Parent.Rows.Count, SortField.Column).End(xlUp)).Value2
On Error Resume Next
For Each Val In Value_Arr
Filter_Values.Add Val, CStr(Val)
Next Val
' Check if Value of LinkedCell is in range
If SortField.Value < 1 Or SortField.Value > Filter_Values.Count Then SortField.Value = 1
' set autofilter
Sort_Value = Filter_Values(SortField.Value)
SortField.Offset(2, 0).AutoFilter SortField.Column, Sort_Value
Application.ScreenUpdating = True
End Sub
This should solve your problem and could be used on different columns and sheets (you have to add another copy of the event-procedures in the worksheet-module).
I would do something like this.
First: Get Help column X where you copy all the Unique data from column B for example.
Option Explicit
Sub CreateUniqueList()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
ActiveSheet.Range("B1:B" & lastrow).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=ActiveSheet.Range("X1"), _
Unique:=True
ActiveSheet.Range("Y1").Value = "x"
End Sub
Your list could lokk after that like this:
After that, you would need a loop for the buttons:
Something like this.
//The Code is not Testet//
Sub butNextValue()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastrow
If ActiveSheet.Cells(i, 25).Value = "x" Then
If Not ActiveSheet.Cells(i+1, 24)-value = "" Then 'check if next value is there
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:=ActiveSheet.Cells(i+1, 24)-value
Else
MsgBox "No more Next Values"
End If
Exit For
End If
Next i
End Sub
Sub butPriValue()
Dim lastrow As Long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lastrow
If ActiveSheet.Cells(i, 25).Value = "x" Then
If Not ActiveSheet.Cells(i-1, 24)-value = "Set" OR Not ActiveSheet.Cells(i-1, 24)-value = "" Then 'check if next value is there
ActiveSheet.Range("$A$2:$V$609").AutoFilter Field:=2, Criteria1:=ActiveSheet.Cells(i-1, 24)
Else
MsgBox "No more Pri Values"
End If
Exit For
End If
Next i
End Sub

Insert entire row based upon prompted cell value

All, I have the following code, but I need to know how to amend it. I need a prompt or message box that asks me, which value in column A to look for. It should the find the corresponding value in Sheet1 Column A, and copy the Data from Column A to AL over to sheet2.
Here's my code:
Sub MM1()
Dim Check As Range, r As Long, lastrow2 As Long, lastrow As Long
Application.ScreenUpdating = False
lastrow = Worksheets("Sheet1").UsedRange.Rows.Count
lastrow2 = Worksheets("Sheet2").UsedRange.Rows.Count
If lastrow2 = 1 Then lastrow2 = 0
For r = lastrow To 2 Step -1
If Range("E" & r).Value = "Yes" Then
Rows(r).Cut Destination:=Worksheets("Sheet2").Range("A" & lastrow2 + 1)
lastrow2 = lastrow2 + 1
Else:
End If
Next r
Application.ScreenUpdating = True
End Sub
Also, this is to be a subset of code which will search for the exact row to insert at.
You don't need to do a manual loop through the rows in sheet1, just use VBA's native Find function. Also You're currently not getting user input, that can be achieved with an InputBox.
See the comments for details about the code.
This example copies the data from the first match:
Sub MM1()
Dim lastrowsheet2 As Long
' Use last cell in UsedRange for its row number,
' if row 1,2,... aren't used, then UsedRange will be shorter than you expect!
With ThisWorkbook.Sheets("Sheet2").UsedRange
lastrowsheet2 = .Cells(.Cells.Count).Row
End With
' Get user input for a search term
Dim userinput As String
userinput = InputBox("Enter a value to search for.", "Column A Search")
' Search for value
Dim findrange As Range
Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
If findrange Is Nothing Then
MsgBox "No matching search results"
Else
lastrowsheet2 = lastrowsheet2 + 1
' Copy values in found row to sheet 2, in new last row
ThisWorkbook.Sheets("Sheet2").Range("A" & lastrowsheet2, "AL" & lastrowsheet2).Value _
= ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AL" & findrange.Row).Value
End If
End Sub
This example copies the data from the every match in the column:
Sub MM1()
' Speed improvements
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Use last cell in UsedRange for its row number,
' if row 1,2,... aren't used, then UsedRange will be shorter than you expect!
Dim lastrowsheet2 As Long
With ThisWorkbook.Sheets("Sheet2").UsedRange
lastrowsheet2 = .Cells(.Cells.Count).Row
' If sheet is completely empty, make sure data will be inserted on row 1 not 2
If lastrowsheet2 = 1 And .Cells(1).Value = "" Then lastrowsheet2 = 0
End With
' Get user input for a search term
Dim userinput As String
userinput = InputBox("Enter a value to search for.", "Column A Search")
' Search for value
Dim findrange As Range
Dim firstaddress As String
Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").Find(what:=userinput, lookat:=xlWhole, LookIn:=xlValues)
If findrange Is Nothing Then
MsgBox "No matching search results"
Else
firstaddress = findrange.Address
Do
lastrowsheet2 = lastrowsheet2 + 1
' Copy values in found row to sheet 2, in new last row
ThisWorkbook.Sheets("Sheet2").Range("A" & lastrowsheet2, "AL" & lastrowsheet2).Value _
= ThisWorkbook.Sheets("Sheet1").Range("A" & findrange.Row, "AL" & findrange.Row).Value
' Find next match
Set findrange = ThisWorkbook.Sheets("Sheet1").Columns("A").FindNext(findrange)
' Loop until the Find has wrapped back around, or value not found any more
Loop While Not findrange Is Nothing And findrange.Address <> firstaddress
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

How to Exclude a Specific Row from a Find Last Column Function

I've created a spreadsheet that creates an inventory list. The Macro i'm writing opens my intranets search page, enters the catalog number in row a (not shown in image). and returns information to the excel sheet. As it enters locations (RIG), It creates a header in row 2. I created a second macro that removes inactive locations. After this filter, I'm left with a cleaner list, but I want to remove the header in row 2 that no longer has information below it (i.e. columns AH, AI, AJ and so on). I know I can find the last used column of the worksheet, but what i want to do is clear formatting , border and contents in row2 whenever row3 to lastrow is empty.
Is there a way to adjust this to exclude the row2 from the search?
Dim LastColumn As Integer
Set LastColumn = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Cells(2,LastColumn).Select
ActiveCell.Offset(0,1)
Do
If not ActiveCell = "" Then
ActiveCell.EntireColumn.Delete(xlToLeft)
DoEvents
Else
Exit Do
End If
Loop
Final Code after incorporating Gary's Students Response. Thank you!!
'Find last used column below header row
Dim wf As WorksheetFunction
Dim N As Long
Dim rCol As Range
Set wf = Application.WorksheetFunction
Cells(1, 1).EntireRow.Hidden = True
Cells(2, 1).EntireRow.Hidden = True
Do
For N = Columns.Count To 1 Step -1
Set rCol = Cells(1, N).EntireColumn
If wf.Subtotal(103, rCol) > 0 Then
Exit Do
End If
Next
Loop
Cells(1, 1).EntireRow.Hidden = False
Cells(2, 1).EntireRow.Hidden = False
'Trim header row to used columns only
Cells(2, N).Select
ActiveCell.Offset(0, 1).Select
Do
If Not ActiveCell = "" Then
ActiveCell.EntireColumn.Delete (xlToLeft)
DoEvents
Else
Exit Do
End If
Loop
Just exclude the row from the examination:
Sub FindLastColumn()
Dim BadRow As Long, wf As WorksheetFunction
Dim N As Long, rCol As Range, i As Long
BadRow = 7
i = 103
Set wf = Application.WorksheetFunction
Cells(BadRow, 1).EntireRow.Hidden = True
For N = Columns.Count To 1 Step -1
Set rCol = Cells(1, N).EntireColumn
If wf.Subtotal(i, rCol) > 0 Then
MsgBox "The last used column is: " & N
Cells(BadRow, 1).EntireRow.Hidden = False
Exit Sub
End If
Next N
Cells(BadRow, 1).EntireRow.Hidden = False
End Sub
So basically from what I can understand you are trying to do a search and exclude some rows from the search? Why not use a double loop?
for i 1 to columns you want
for j = 1 to rows you want
if j <> row you don't want
'add code here
end if
nextj
next i

Concatenate columns(user selected) and replace them with new column

I'm not an advanced VBA programmer. I'm working on an excel macro which will allow me to select a range(using input box) to clean the data(makes consistent with mySQL schema) on worksheet. I get this file from anther team and
1.) the order of columns is not fixed
2) levels of categories(there are few columns for categories like level1 level2 etc.) can be anything between 3-10.
I want to concatenate the columns for categories(in image level 1, level 2 etc.) using | as a separator and put the values in first category column(level1) while deleting remaining columns(level 2, level 3...[level 10]).
I removed some code from the end to reduce the length here but it still makes sense:
Sub cleanData()
Dim rngMyrange As Range
Dim cell As Range
On Error Resume Next
Do
'Cleans Status column
Set rngMyrange = Application.InputBox _
(Prompt:="Select Status column", Type:=8)
On Error GoTo 0
'Is a range selected? Exit sub if not selected
If rngMyrange Is Nothing Then
End
Else
Exit Do
End If
Loop
With rngMyrange 'with the range just selected
.Replace What:="Dead", Replacement:="Inactive", SearchOrder:=xlByColumns, MatchCase:=False
'I do more replace stuff here
End With
rngMyrange.Cells(1, 1) = "Status"
Do
'Concatenates Category Columns
Set rngMyrange = Application.InputBox _
(Prompt:="Select category columns", Type:=8)
On Error GoTo 0
'Is a range selected? Exit sub if not selected
If rngMyrange Is Nothing Then
End
Else
Exit Do
End If
Loop
With rngMyrange 'with the range just selected
'Need to concatenate the selected columns(row wise)
End With
rngMyrange.Cells(1, 1) = "Categories"
End Sub
Please do not suggest a UDF, I want to do this with macro. I must do this on files before importing them on SQL database, so a macro will be handy. Please ask if I failed to mention anything else.
EDIT: Image attached for illustration
UPDATE:
I now have a working code with help from vaskov17 on mrexcel but it does not delete the columns from where the levels are picked-level 2, level 3...etc. to shift next columns to left and the major challenge for me is to implement that code in my existing macro using range type instead of long type. I do not want to enter start column and finish column separately, instead I should be able to select range like in my original macro. Code for that macro is below, please help me:
Sub Main()
Dim start As Long
Dim finish As Long
Dim c As Long
Dim r As Long
Dim txt As String
start = InputBox("Enter start column:")
finish = InputBox("Enter ending column:")
For r = 2 To Cells(Rows.Count, "A").End(xlUp).Row
For c = start To finish
If Cells(r, c).Text <> "" Then
txt = txt & Cells(r, c).Text & "|"
Cells(r, c).Clear
End If
Next
If Right(txt, 1) = "|" Then
txt = Left(txt, Len(txt) - 1)
End If
Cells(r, start) = txt
txt = ""
Next
End Sub
I have removed the inputbox for selection of the category columns. Since they are always named Level x»y it makes it easier to find them automatically. That's why added a FindColumns() Sub to your code. It assigns the first fCol and last lCol Category column to global variables.
The ConcatenateColumns() concatenates cells in each row using "|" as separator.
The DeleteColumns() deletes the other columns
Cells(1, fCol).Value = "Category renames Level 1 to Category and Columns.AutoFit resizes all columns widths to fit the text.
Code:
Option Explicit
Dim fCol As Long, lCol As Long
Sub cleanData()
Dim rngMyrange As Range
Dim cell As Range
On Error Resume Next
Do
'Cleans Status column
Set rngMyrange = Application.InputBox _
(Prompt:="Select Status column", Type:=8)
On Error GoTo 0
'Is a range selected? Exit sub if not selected
If rngMyrange Is Nothing Then
End
Else
Exit Do
End If
Loop
With rngMyrange 'with the range just selected
.Replace What:="Dead", Replacement:="Inactive", SearchOrder:=xlByColumns, MatchCase:=False
'I do more replace stuff here
End With
rngMyrange.Cells(1, 1) = "Status"
' Concatenate Category Columns
FindColumns
ConcatenateColumns
DeleteColumns
Cells(1, fCol).Value = "Category"
Columns.AutoFit
End Sub
Private Sub FindColumns()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim i As Long, j As Long
For i = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column
If StrComp(ws.Cells(1, i).Text, "Level 1", vbTextCompare) = 0 Then
For j = i To ws.Cells(1, Columns.Count).End(xlToLeft).Column
If InStr(1, ws.Cells(1, j).Text, "Level", vbTextCompare) Then
lCol = j
End If
Next j
fCol = i
Exit Sub
End If
Next i
End Sub
Private Sub ConcatenateColumns()
Dim rng As Range
Dim i As Long, j As Long
For i = 2 To Cells(Rows.Count, fCol).End(xlUp).Row
Set rng = Cells(i, fCol)
For j = fCol + 1 To lCol
rng = rng & "|" & Cells(i, j)
Next j
rng = "|" & rng & "|"
Set rng = Nothing
Next i
End Sub
Private Sub DeleteColumns()
Dim i As Long
For i = lCol To fCol + 1 Step -1
Columns(i).Delete Shift:=xlToLeft
Next i
End Sub

Is it possible to get a % of (name)/total using VBA?

I was wondering if anyone knows how to get a % of say dctest/In using VBA excel?
dctest for this example is just some tested perimeter while the In can be considered as the total number of devices set to do the dc test.
I have provided an image for better understanding. Both set of results shown are before and after converting the values into %. What i'm required will be finding the % of all tests except for test1-test6. The denominator will be values of In, ie, dctest/In.
I have tried some coding, but am not very sure of how to get the percentage of the values.
Sub macro1()
Dim testrow As Long, testcell As Range, lastrowval As Long
testrow = 1 'initialise
Do
Set testcell = Sheets("Summary").Cells(testrow, 1)
'To look for any test1-test6, if there is do nothing
If testcell = "test1" Or testcell = "test2" Or testcell = "test3" Or testcell = "test4" Or testcell = "test5" Or testcell = "test6" Then
'Do nothing
Exit Do
End If
testrow = testrow + 1
Loop
Do
Set testcell = Sheets("Summary").Cells(testrow, 1)
If testcell = "Resultant" Then
lastrowval = testrow
Exit Do
End If
testrow = testrow + 1
Loop
End Sub
Do take note that, I'm aware of the use of the fixed formula that excel can do, but at times some of the tests such as ACtest will not be there OR there will be an extra test such as morning test, this will affect the fixed formula.
Do take note also that test1 - test6, sometimes all 6 tests will be present, at times only 1 test will be present.
What my concern is if there is an extra test say test1 added in, the row from dctest..... Resultant will be shifted down by 1 row.
And if there is a test say test6 got removed, the row from dctest.... resultant will be shifted up by 1 row. I'm not very sure what can be done to make sure this issues can be solved.
Follow up
I have taken the same example as shown in the picture. Like your previous question, you can either use a formula or a code.
Formula
In Cell J7, enter this formula and then right click on the cell to format as %age.
=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(I7,$A$1:$A$11,0),1,0),1,1,1)),0,1)/$B$1
If you need then simply copy the formula down
Code
Sub Sample()
With Range("J7")
.FormulaR1C1 = _
"=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(RC[-1],R1C1:R11C1,0),1,0),1,1,1)),0,1)/R1C2"
.NumberFormat = "0.00%"
End With
End Sub
OR
Sub Sample()
With Range("J7")
.Formula = _
"=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(I7,$A$1:$A$11,0),1,0),1,1,1)),0,1)/$B$1"
.NumberFormat = "0.00%"
End With
End Sub
FOLLOWUP
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim SearchText As String, Excludetext As String
Dim LastRow As Long, i As Long, j As Long
Dim MyArray() As String
Dim boolContinue As Boolean
'~~> Add/Remove the text here which you want to ignore
Excludetext = "In,Test1,Test2,Test3,Test4,Test5,Test6"
MyArray = Split(Excludetext, ",")
Set ws = Sheets("Sheet1")
LastRow = ws.Range("I" & Rows.Count).End(xlUp).Row
For i = 1 To LastRow
boolContinue = True
For j = 0 To UBound(MyArray)
SearchText = Ucase(Trim(MyArray(j)))
If Ucase(Trim(ws.Range("I" & i).Value)) = SearchText Then
boolContinue = False
Exit For
End If
Next j
If boolContinue = True Then
With Range("J" & i)
.Formula = _
"=OFFSET(INDIRECT(ADDRESS(INDEX(MATCH(I" & i & _
",$A$1:$A$11,0),1,0),1,1,1)),0,1)/$B$1"
.NumberFormat = "0.00%"
End With
End If
Next i
End Sub
HTH
Sid
Why don't you just turn it into a percent part/whole=x/100