I am trying to write a macro that hides the row if the cell value equals the next visible cell in that column and loops through the whole column. I have read that SpecialCells(xlCellTypeVisible) only works up to 8192 cells and my spreadsheet has 15,000 rows.
I have tried something like this but want to restrict it to only visible cells
Sub Test()
For i = 7 To 15258
If Range("P" & i).Value = Range("P" & i + 1).Value Then
Rows(i).Hidden = True
End If
Next i
End Sub
I have tried to search for a solution but haven't been able to find one yet.
Thanks!
I'd be surprised if this couldn't be optimized just a little bit, but it will work for what you are needing.
You can follow the comments within the code itself to kind of get a sense of what it's doing, but in a nutshell, you are using a For...Next statement to loop through your visible cells. For each visible cell, you will search for the next visible cell and then check to see if that matches. If it does, you add that cell to a special range that tracks all the rows to hide at the end of the code, then hide it.
Sub Test()
Dim ws As Worksheet, lookupRng As Range, rng As Range, lstRow As Long
Set ws = ThisWorkbook.Worksheets(1)
lstRow = 15258
Set lookupRng = ws.Range("P7:P" & lstRow)
Dim rngToHide As Range, i As Long
For Each rng In lookupRng.SpecialCells(xlCellTypeVisible)
Application.StatusBar = "Checking row " & rng.Row & " for matches."
For i = rng.Row + 1 To lstRow 'Loop through rows after rng
If Not ws.Rows(i).Hidden Then 'Check if row is hidden
If rng.Value = ws.Cells(i, "P") Then 'check if the non-hidden row matches
If rngToHide Is Nothing Then 'Add to special range to hide cells
Set rngToHide = ws.Cells(i, "P")
Else
Set rngToHide = Union(rngToHide, ws.Cells(i, "P"))
End If
End If
Exit For 'Exit the second For statement
End If
Next i
Next rng
Application.StatusBar = "Hiding duplicate rows"
If Not rngToHide Is Nothing Then rngToHide.EntireRow.Hidden = True
Application.StatusBar = False
End Sub
Related
I am trying to search for values listed in a column from multiple sheets in my excel workbook. If excel finds a match I would like it to return sheet names of the tabs that had the value.
Here is what i have done so far. I decided to start off by using one keyword to search multiple tabs, copy and paste the sheet name. The code below only paste the first resulting sheet name when there are other sheets containing the same keyword. I would like to know how i can pull the other sheet names that contain the same keyword.
I would also like to know how i can set up the keyword to use information in Column A of the Field List.
Sub FinalAppendVar()
Dim ws As Worksheet
Dim arr() As String
Keyword = "adj_veh_smart_tech_disc"
Totalsheets = Worksheets.Count
For i = 1 To Totalsheets
If Worksheets(i).Name <> "Main" Or InStr(1, Worksheets(i).Name, " Checks") Or Worksheets(i).Name
<>_ "Field Lists" Then
lastrow = Worksheets(i).Cells(Rows.Count, 4).End(xlUp).Row
For j = 2 To lastrow
If Worksheets(i).Cells(1, 3).Value = Keyword Then
Worksheets("Field Lists").Activate
lastrow = Worksheets("Field Lists").Cells(Rows.Count, 4).End(xlUp).Row
Worksheets("Field Lists").Cells(lastrow + 1, 5).Value = Worksheets(i).Name
Worksheets("Field Lists").Cells(lastrow + 2, 5).Value = Worksheets(i).Name
End If
Next
End If
Next
End Sub
The following code should work for what you described.
A couple feedback items:
Tabbing out loops and if statements significantly improves code readability
Never reuse variable names (i.e. lastrow), it makes it hard to read and can cause issues that are difficult to find later on
Follow all Next with the loop variable (i.e. Next i), this improves readability and helps you keep track of the ends of loops
.Activate and .Select are generally never required in vba, its better to be explicit in what you are referencing
Sub FinalAppendVar()
Dim searchSheet As Excel.Worksheet
Dim pasteSheet As Excel.Worksheet
Dim keyword As String
Dim lastSearchRow As Integer
Dim lastPasteRow As Integer
' set the worksheet to paste to
Set pasteSheet = ThisWorkbook.Worksheets("Field Lists")
' set keyword to look for
keyword = "adj_veh_smart_tech_disc" '<-- manual entry
'keyword = pasteSheet.Range("A1").Value '<-- use value in cell A1 on the defined pasteSheet
' loop through all sheets in the workbook
For i = 1 To ThisWorkbook.Worksheets.Count
' set the current worksheet we are looking at
Set searchSheet = ThisWorkbook.Worksheets(i)
' check if the current sheet is one we want to search in
If searchSheet.Name <> "Main" Or InStr(1, searchSheet.Name, " Checks") Or searchSheet.Name <> "Field Lists" Then
' current worksheet is one we want to search in
' find the last row of data in column D of the current sheet
lastSearchRow = searchSheet.Cells(1048576, 4).End(xlUp).Row
' loop through all rows of the current sheet, looking for the keyword
For j = 2 To lastSearchRow
If searchSheet.Cells(j, 3).Value = keyword Then
' found the keyword in row j of column C in the current sheet
' find the last row of column D in the paste sheet
'lastPasteRow = pasteSheet.Cells(1048576, 4).End(xlUp).Row
lastPasteRow = pasteSheet.Cells(1048576, 5).End(xlUp).Row '<-- update based on OPs comment
' paste the name of the current search sheet to the last empty cell in column E
pasteSheet.Cells(lastPasteRow + 1, 5).Value = searchSheet.Name
' not sure if the next line is needed, looks like it pastes again immediately below the previous
pasteSheet.Cells(lastPasteRow + 2, 5).Value = searchSheet.Name
' to save time consider exiting the search in the current sheet since the keyword was just found
' this will move to the next sheet immediately and not loop through the rest of the rows on the current
' search sheet. This may not align with the usecase so it is currently commented out.
'Exit For '<--uncomment this to move to the next sheet after finding the first instance of the keyword
Else
' the keyoword was not in row j of column C
' do nothing
End If
Next j
Else
' current sheet is one we don't want to search in
' do nothing
End If
Next i
End Sub
Please try this variant (Don't worry that the code is so long - the longer the programmer thought and the more wrote, the better the program works ... usually it is):
Option Explicit
Sub collectLinks()
Const LIST_SHEET_NAME As String = "Field Lists"
Dim wsTarget As Worksheet
Dim wsEach As Worksheet
Dim keywordCell As Range
Dim sKeyword As String
Dim linkCell As Range
Dim aFound As Range
Dim aCell As Range
On Error Resume Next
Set wsTarget = ActiveWorkbook.Worksheets(LIST_SHEET_NAME)
On Error GoTo 0
If wsTarget Is Nothing Then
MsgBox "'" & LIST_SHEET_NAME & "' not exists in active workbook", vbCritical, "Wrong book or sheet name"
Exit Sub
End If
Rem Clear all previous results (from column B to end of data)
wsTarget.UsedRange.Offset(0, 1).ClearContents
Rem Repeat for each cell of column A in UsedRange:
For Each keywordCell In Application.Intersect(wsTarget.UsedRange, wsTarget.Columns("A")) ' It can be changed to "D", "AZ" or any other column
sKeyword = keywordCell.Text
If Trim(sKeyword) <> vbNullString Then
Application.StatusBar = "Processed '" & sKeyword & "'"
Set linkCell = keywordCell
For Each wsEach In ActiveWorkbook.Worksheets
If wsEach.Name <> LIST_SHEET_NAME Then
Application.StatusBar = "Processed '" & sKeyword & "' Search in '" & wsEach.Name & "'"
Set aFound = FindAll(wsEach.UsedRange, sKeyword)
If Not aFound Is Nothing Then
For Each aCell In aFound
Set linkCell = linkCell.Offset(0, 1) ' Shift to rught, to the next column
linkCell.Formula2 = "=HYPERLINK(""#" & aCell.Address(False, False, xlA1, True) & """,""" & _
aCell.Worksheet.Name & " in cell " & aCell.Address(False, False, xlA1, False) & """)"
Next aCell
End If
End If
Next wsEach
End If
Next keywordCell
Application.StatusBar = False
Rem Column width
wsTarget.UsedRange.Columns.AutoFit
End Sub
Function FindAll(SearchRange As Range, FindWhat As Variant) As Range
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
Rem If your keyword can be a part of cell then change parameter xlWhole to xlPart:
Set FoundCell = SearchRange.Find(FindWhat, LastCell, xlValues, xlWhole, xlByRows)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function
You can see how it works in this demo workbook - Create Links To Keywords.xlsm
EDIT By the way, the second part of this code, the FindAll() function, is a slightly shortened version of the Chip Pearson macro. Keep this link for yourself, there are many useful things to help you in future development.
I'm a beginner. Just learning by Googleing, but cannot find a solution for this. Please help.
I want to run the below macro.
I have multiple cells named "CV_=CVCAL" in the same column.
What I want is for the macro to find the first cell with the value "CV_=CVCAL" and offset to the adjacent cell. If the adjacent cell has a particular value, if the value is below lets say "1.5" i want to fill it will a cell style 'bad'.
I want the macro to go through all the cells that have the name CV_=CVCAL and do the same thing until there is no more cells named CV_=CVCAL.
Sub If_CV()
Range("A1").Select
Set FoundItem = Range("C1:C1000").Find("CV_=CVCAL")
FoundItem.Offset(columnOffset:=1).Select
If ActiveCell.Value >= 1.5 Then
ActiveCell.Style = "Bad"
End If
End Sub
Sounds like you want to loop through your values.
Determine the end of your range
Loop through your range and check your criteria
Sub If_CV()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lr As Long, i As Long
lr = ws.Range("C" & ws.Rows.Count).End(xlUp).Row
For i = 2 To lr
If ws.Range("C" & i) = "CV_=CVCAL" Then
If ws.Range("D" & i) >= 1.5 Then
ws.Range("D" & i) = "Bad"
End If
End If
Next i
End Sub
A basic loop would be simpler:
Sub If_CV()
Dim c As Range, ws As Worksheet
For Each ws in ActiveWorkbook.Worksheets
For Each c in ws.Range("C1:C1000").Cells
If c.Value = "CV_=CVCAL" Then
With c.offset(0, 1)
If .Value >= 1.5 Then .Style = "Bad"
End With
End If
Next ws
Next c
End Sub
I have a cell designated as a Search Box for user entry (called 'UserSearch') and need to be able to use this input to filter multiple columns at the same time. For example, if the user searched for 'Apple', I need the VBA code to filter out all rows where that word appears, even if it appeared in another column. I am currently stuck on only being able to filter out one column at a time but this input may also appear in another column but the row won't be filtered because it may have gotten filtered out by the column before it.
My current code is below is:
Sub search()
With ActiveSheet.Range("$a$4:$j$30")
.AutoFilter Field:=1, Criteria1:="=*" & Range("UserSearch") & "*", Operator:=xlOr
.AutoFilter Field:=2, Criteria1:="=*" & Range("UserSearch") & "*", Operator:=xlOr
.AutoFilter Field:=3, Criteria1:="=*" & Range("UserSearch") & "*"
End With
End Sub
As you can see, my goal is to be able to run autofilter on all 3 fields simultaneously (essentially treating the 3 columns as just one) but the code above contradicts each other and no rows are returned. Anyone have any idea by using autofilter?
You cannot use .AutoFilter for this but yes using a small vba code you can achieve what you want
Let's say your worksheet looks like this
Paste this code in a module
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim rngHide As Range
Dim FoundIt As Long, i As Long, lRow As Long
Dim SearchString As String
'~~> Your search string
SearchString = "Apple"
'~~> Change this to the relevant sheet
Set ws = Sheet1
'~~> Find the last row
' https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
'~~> Loop through 4 to last row to find the search string
For i = 4 To lRow
On Error Resume Next
FoundIt = Application.WorksheetFunction.Match(SearchString, ws.Rows(i), 0)
On Error GoTo 0
'~~> Create a range which needs to be hidden
If FoundIt = 0 Then
If rngHide Is Nothing Then
Set rngHide = ws.Rows(i)
Else
Set rngHide = Union(rngHide, ws.Rows(i))
End If
End If
FoundIt = 0
Next i
'~~> Hide it if applicable
If Not rngHide Is Nothing Then rngHide.EntireRow.Hidden = True
End Sub
I have commented the code so you should not have a problem understanding it. but if you do then simply ask.
In Action
These two macros are more basic, but accomplish the same task as Sid's answer...
The first macro loops through the range and checks the first three cells in the current row for the search text, if found in any of the cells, it will loop to the next row. If no cells contain the search text, the row will be hidden
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Define your worksheet
Dim UserSearch As String: UserSearch = ws.Range("A2").Value 'Assign the range for the user entry, change as needed
For Each cel In ws.Range("A4", ws.Cells(ws.Rows.Count, 1).End(xlUp)) 'Loop through the range
'Using (= and Or) test if any of the first three cells in the current row contain the search text
If cel.Value = UserSearch Or cel.Offset(, 1).Value = UserSearch Or cel.Offset(, 2).Value = UserSearch Then
'If the search text is found in any of the cells then loop to the next row
Else
'If the search text is not in any of the cells then hide the row
cel.EntireRow.Hidden = True
End If
Next cel
The second macro loops through the range and checks the first three cells in the current row for the search text, if not found, the row will be hidden
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1") 'Define your worksheet
Dim UserSearch As String: UserSearch = ws.Range("A2").Value 'Assign the range for the user entry, change the range as needed
For Each cel In ws.Range("A4", ws.Cells(ws.Rows.Count, 1).End(xlUp)) 'Loop through the range
'Using (<> and And) test the first three cells in the current row
If cel.Value <> UserSearch And cel.Offset(, 1).Value <> UserSearch And cel.Offset(, 2).Value <> UserSearch Then
'If the search text is not found hide the current row
cel.EntireRow.Hidden = True
End If
Next cel
I have written a few lines of code that work like I want them too but I don't know how to repeat it through all rows of my data.
This probably seems like a rather simple thing but since I started VBA just a few days ago I struggle with this line of code
If I continue with ActiveCell.Offset(-1,-4) after my code it's a bug and I don't know how to repeat the code through all rows.
Sub SelectRowsWithNoBlanks()
Range("A2").Select
If ActiveCell.Offset(0, 0).Value <> "" And ActiveCell.Offset(0, 1) <> "" And ActiveCell(0, 1) <> "" And ActiveCell(0, 1) <> "" Then
Range(ActiveCell, Cells(ActiveCell.Row, ActiveCell.Column + 4)).Select
End If
End Sub
#SiddharthRout As I don't have Access to the data yet I can't tell. But I thought extending the code for more columns later on wouldn't be a problem. So in the code I have written now I was checking for the columns A-D but I thought I could easily add the "checking" for more columns if needed – Anna von Blohn 43 secs ago
In that case, here is a sample code.
Logic
As #Pᴇʜ mentioned avoid the use of .Select. Work with the objects.
Find the last row and loop through the rows. To find the last you you may want to see This
One way (which I am using) is to count the number of cells which are filled using Application.WorksheetFunction.CountA. So if it is columns A to D then there should be 4 cells to be filled to consider the "row" as filled. Similarly for Cols A to E, there should be 5 cells to be filled to consider the "row" as filled as so on.
Code
I have commented the code. So if you have a problem understanding it, let me know.
Option Explicit
Sub SelectRowsWithNoBlanks()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim myRange As Range, rng As Range
'~~> Change this to the relevant sheet
Set ws = Sheet1
With ws
'~~> Find the last row in Col A
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow
'~~> Change this as applicable
Set rng = .Range("A" & i & ":D" & i)
'~~> Check if the range is completely filled
If Application.WorksheetFunction.CountA(rng) = rng.Columns.Count Then
'~~> Store the range in a range object
If myRange Is Nothing Then
Set myRange = rng
Else
Set myRange = Union(myRange, rng)
End If
End If
Next i
End With
'If Not myRange Is Nothing Then Debug.Print myRange.Address
'~~> Check if any filled rows were found
If Not myRange Is Nothing Then
With myRange
'
'~~> Do what you want with the range
'
End With
Else
MsgBox "No filled rows were found"
End If
End Sub
I need to find out the first cell and the last cell of a vertically merged cell..
Let's say I merge Cells B2 down to B50.
How can I get in VBA the start cell(=B2) and the end cell(=B50)?
Sub MergedAreaStartAndEnd()
Dim rng As Range
Dim rngStart As Range
Dim rngEnd As Range
Set rng = Range("B2")
If rng.MergeCells Then
Set rng = rng.MergeArea
Set rngStart = rng.Cells(1, 1)
Set rngEnd = rng.Cells(rng.Rows.Count, rng.Columns.Count)
MsgBox "First Cell " & rngStart.Address & vbNewLine & "Last Cell " & rngEnd.Address
Else
MsgBox "Not merged area"
End If
End Sub
Below macro goes through all sheets in a workbook and finds merged cells, unmerge them and put original value to all merged cells.
This is frequently needed for DB applications, so I wanted to share with you.
Sub BirlesenHucreleriAyirDegerleriGeriYaz()
Dim Hucre As Range
Dim Aralik
Dim icerik
Dim mySheet As Worksheet
For Each mySheet In Worksheets
mySheet.Activate
MsgBox mySheet.Name & “ yapılacak…”
For Each Hucre In mySheet.UsedRange
If Hucre.MergeCells Then
Hucre.Orientation = xlHorizontal
Aralik = Hucre.MergeArea.Address
icerik = Hucre
Hucre.MergeCells = False
Range(Aralik) = icerik
End If
Next
MsgBox mySheet.Name & " Bitti!!"
Next mySheet
End Sub
Suppose you merged B2 down to B50.
Then, start cell address will be:
MsgBox Range("B2").MergeArea.Cells(1, 1).Address
End cell address will be:
With Range("B2").MergeArea
MsgBox .Cells(.Rows.Count, .Columns.Count).Address
End With
You can put address of any cell of merged area in place of B2 in above code.
Well, assuming you know the address of one of the cells in the merged range, you could just select the offset from that range and get the row/column:
Sub GetMergedRows()
Range("A7").Select 'this assumes you know at least one cell in a merged range.
ActiveCell.Offset(-1, 0).Select
iStartRow = ActiveCell.Row + 1
Range("A7").Select
ActiveCell.Offset(1, 0).Select
iEndRow = ActiveCell.Row - 1
MsgBox iStartRow & ":" & iEndRow
End Sub
The code above will throw errors if the offset row cannot be selected (i.e. if the merged rows are A1 through whatever) so you will want to add error handling that tells the code if it can't offset up, the top rows must be 1 and if it can't go down, the bottom row must be 65,536. This code is also just one dimensional so you might want to add the x-axis as well.
If you want the cell references as strings, you can use something like this, where Location, StartCell, and EndCell are string variables.
Location = Selection.Address(False, False)
Colon = InStr(Location, ":")
If Colon <> 0 Then
StartCell = Left(Location, Colon - 1)
EndCell = Mid(Location, Colon + 1)
End If
If you want to set them as ranges, you could add this, where StartRange and EndRange are Range objects.
set StartRange = Range(StartCell)
set EndRange = Range (EndCell)
If you intend to loop through the merged cells, try this.
Sub LoopThroughMergedArea()
Dim rng As Range, c As Range
Set rng = [F5]
For Each c In rng.MergeArea
'Your code goes here
Debug.Print c.Address'<-Sample code
Next c
End Sub