I have sheet 1 with range of names. I have a msg box input where I can just click the cell referencing the value. If it matches, it finds where that value lies in column C of sheet 2. It works how I want it to, but I need to figure out how to highlight the whole row. Also, is there a scroll to indexing I can do to make sure it moves down sheet 2 to where that row was highlighted?
Code:
Sub tgr()
Dim rFound As Range
Dim lemployee As String
Dim sh As Worksheet
Dim rw As Long
Dim matched As Boolean
lemployee = Application.InputBox("Please selct an employee", "Employee Name", Type:=2)
If lemployee = "False" Then Exit Sub
Set sh = Sheets("Sheet1")
rw = 2
With ThisWorkbook.Worksheets("Sheet2").Columns("C")
Set rFound = .Find(lemployee, .Cells(.Cells.Count), xlValues, xlWhole)
If ThisWorkbook.Worksheets("Sheet2").Cells(rFound.Row, 3).Value = lemployee Then
.Cells(rFound.Row).Interior.Color = VBA.RGB(255, 255, 0)
End If
End With
End Sub
EDIT: As for the scroll, I would just need something like:
Application. Goto ActiveCell.EntireRow,True
Something like this:
With ThisWorkbook.Worksheets("Sheet2").Columns("C")
Set rFound = .Find(lemployee, .Cells(.Cells.Count), xlValues, xlWhole)
If Not rFound Is Nothing Then
rFound.EntireRow.Interior.Color = VBA.RGB(255, 255, 0)
Application.Goto rFound
End If
End With
Related
Looking for help to achieve searching a range of cells E9:E with All cells containing "Accommodation & Transportation" and changing the value of the cells adjacent to them with 0. , I was not able to get anything online with similar topic and I'm not too good with VBA coding, though i am able to understand what the code will provide in results.
I Have a Commandbutton1 with the below code :
Sub CommandButton1_click()
Dim blanks As Excel.Range
Set blanks = Range("F9:F" & Cells(Rows.Count, 5).End(xlUp).Row).SpecialCells(xlCellTypeBlanks)
blanks.Value = blanks.Offset(0, -1).Value
End Sub
Further i have a command button that will select only cells that are not blank. I need the above result because if the below code selects Non Blank cells from Columns E:F it wont be selecting cells adjacent to those containing "Accommodation & Transportation" as they are blank cells and it will return the error "Runtime Error '1004' This action wont work on multiple selections".
The below code acts the same as [Go to Special => Constants]
Sub SelectNonBlankCells()
Dim rng As Range
Dim OutRng As Range
Dim InputRng As Range
Dim xTitle As String
On Error Resume Next
xTitle = Application.ActiveWindow.RangeSelection.Address
Set InputRng = Range("E8:F500")
ActiveWindow.ScrollRow = 1
For Each rng In InputRng
If Not rng.Value = "" Then
If OutRng Is Nothing Then
Set OutRng = rng
Else
Set OutRng = Application.Union(OutRng, rng)
End If
End If
Next
If Not (OutRng Is Nothing) Then
OutRng.Select
End If
End Sub
Maybe you can try another approach, if your goal is to edit cells adjacent to certain cells. The code below is based on an example in the Help file of the Range.Find function:
Sub DoSomething()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim checkRange As Range
Set checkRange = sh.Range("E8:F500") ' your intended range to search
Dim foundRange As Range
Set foundRange = checkRange.Find("Accommodation & Transportation")
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = checkRange.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
Or even better, you could add some parameters to make it more reusable:
Sub Main()
DoSomething "Accommodation & Transportation", ActiveSheet.Range("E8:F500")
End Sub
Sub DoSomething(ByVal findWhat As String, ByVal searchWhere As Range)
Dim foundRange As Range
Set foundRange = searchWhere.Find(findWhat)
Dim firstAddr As String
If Not foundRange Is Nothing Then
firstAddr = foundRange.Address
Do
' use foundRange to access adjacent cells with foundRange.Offset(row, col)
'
'
foundRange.Offset(0, 1) = "all good"
Set foundRange = searchWhere.FindNext(foundRange)
Loop While Not foundRange Is Nothing And foundRange.Address <> firstAddr
End If
End Sub
search entire Excel workbook for text string and highlight cell appears to be exactly what I need but I can't get it to work on my Excel workbook. I have hundreds of rows across 10 worksheets. All searched-for Strings (Packet 01, Packet 02, Packet 03, etc) would be in B:8 to row-end on worksheet(1) and B:7 to row-end on the other 9 worksheets (Worksheets are named and the InputBox result for the string would need to be case-sensitive). 45547221 indicates interior color change, but there would be too much color with all strings having cells in different colors, thus changing the string color would be better using font.color.index. Trying the 45547221 code as-is finds it skipping the Do/Loop While code when in step mode.
I would modify the code in 45547221 by adding at a minimum:
Dim myColor As Integer
myColor = InputBox("Enter Color Number (1-56)")
(Configured so I can enter up to 5 FindStrings and 5 ColorIndex numbers as Dim with InputBox(es))
In the Do/Loop While I would change .ColorIndex = myColor
I would like to get this code working as it seems to fit my needs - modified to find string instances across workbook and re-color string instead of cell interior colors and (2) get it to recognize the Do/Loop While code which it isn't now but would apply the ColorIndex number to each string.
Public Sub find_highlight()
'Put Option Explicit at the top of the module and
'Declare your variables.
Dim FindString As String
Dim wrkSht As Worksheet
Dim FoundCell As Range
Dim FirstAddress As String
Dim MyColor As Integer 'Added this
FindString = InputBox("Enter Search Word or Phrase")
MyColor = InputBox("Enter Color Number")
'Use For...Each to cycle through the Worksheets collection.
For Each wrkSht In ThisWorkbook.Worksheets
'Find the first instance on the sheet.
Set FoundCell = wrkSht.Cells.Find( _
What:=FindString, _
After:=wrkSht.Range("B1"), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'Check it found something.
If Not FoundCell Is Nothing Then
'Save the first address as FIND loops around to the start
'when it can't find any more.
FirstAddress = FoundCell.Address
Do
With FoundCell.Font 'Changed this from Interior to Font
.ColorIndex = MyColor
'.Pattern = xlSolid
'.PatternColorIndex = xlAutomatic 'Deactivated this
End With
'Look for the next instance on the same sheet.
Set FoundCell = wrkSht.Cells.FindNext(FoundCell)
Loop While FoundCell.Address <> FirstAddress
End If
Next wrkSht
End Sub
EDIT: This worked for me on your sample data, using a partial match so you can enter (eg) "Packet 03" and still match.
I like to split out the "find all" function into a separate function: it makes the rest of the logic easier to follow.
Public Sub FindAndHighlight()
Dim FindString As String
Dim wrkSht As Worksheet
Dim FoundCells As Range, FoundCell As Range
Dim MyColor As Integer 'Added this
Dim rngSearch As Range, i As Long, rw As Long
FindString = InputBox("Enter Search Word or Phrase")
MyColor = InputBox("Enter Color Number")
'Cycle through the Worksheets
For i = 1 To ThisWorkbook.Worksheets.Count
Set wrkSht = ThisWorkbook.Worksheets(i)
rw = IIf(i = 1, 8, 7) '<<< Row to search on
' row 8 for sheet 1, then 7
'set the range to search
Set rngSearch = wrkSht.Range(wrkSht.Cells(rw, "B"), _
wrkSht.Cells(Rows.Count, "B").End(xlUp))
Set FoundCells = FindAll(rngSearch, FindString) '<< find all matches
If Not FoundCells Is Nothing Then
'got at least one match, cycle though and color
For Each FoundCell In FoundCells.Cells
FoundCell.Font.ColorIndex = CInt(MyColor)
Next FoundCell
End If
Next i
End Sub
'return a range containing all matching cells from rng
Public Function FindAll(rng As Range, val As String) As Range
Dim rv As Range, f As Range
Dim addr As String
'partial match...
Set f = rng.Find(what:=val, after:=rng.Cells(rng.Cells.CountLarge), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=True) 'case-sensitive
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
If rv Is Nothing Then
Set rv = f
Else
Set rv = Application.Union(rv, f)
End If
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
tldr: Find cell(s) with part number xxxxx and add hyperlink to drawing on server.
We have a spreadsheet containing part numbers across multiple columns & rows. Our requirement is to add a hyperlink to parts' drawing, stored on our server. We have tried highlighting them as a group, but get the error
this can't be done on multiple range selection
We also want to keep the comment information intact, just to complicate it further.
Is there code we can use to search for part number xxxxx & add a hyperlink, then find the next cell and repeat the process?
We have found a "find all" code which highlights the cells, just need some help with the hyperlink issue.
Sub FindAll()
Dim fnd As String, FirstFound As String
Dim FoundCell As Range, rng As Range
Dim myRange As Range, LastCell As Range
'What value do you want to find (must be in string form)?
fnd = "70005"
Set myRange = ActiveSheet.UsedRange
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(what:=fnd, after:=LastCell)
'Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo NothingFound
End If
Set rng = FoundCell
'Loop until cycled through all unique finds
Do Until FoundCell Is Nothing
'Find next cell with fnd value
Set FoundCell = myRange.FindNext(after:=FoundCell)
'Add found cell to rng range variable
Set rng = Union(rng, FoundCell)
'Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then Exit Do
Loop
'Select Cells Containing Find Value
rng.Select
Exit Sub
'Error Handler
NothingFound:
MsgBox "No values were found in this worksheet"
End Sub
Your method can be simplified a bit. My suggestion is to create a function that will add your hyperlinks to any given area.
My test data is
Option Explicit
Sub test()
Dim linkCount As Long
linkCount = AddHyperLinkTo(FindArea:=Sheet1.UsedRange, _
FindThis:="red", _
Link:="https://google.com")
Debug.Print "found: " & linkCount
End Sub
Function AddHyperLinkTo(ByRef FindArea As Range, _
ByVal FindThis As Variant, _
ByVal Link As String) As Long
Dim numberFound As Long
Dim parentWS As Worksheet
Set parentWS = FindArea.Parent
Dim firstFind As Range
Dim findResult As Range
Set findResult = FindArea.Find(What:=FindThis, LookIn:=xlValues)
Set firstFind = findResult
Do Until findResult Is Nothing
parentWS.Hyperlinks.Add Anchor:=findResult, Address:=Link
numberFound = numberFound + 1
Set findResult = FindArea.Find(What:=FindThis, LookIn:=xlValues, After:=findResult)
If findResult.Address = firstFind.Address Then
Exit Do
End If
Loop
AddHyperLinkTo = numberFound
End Function
I have a 2 columns range as the first image shows, and a userform with a 2 column listbox, a textbox and a commandbutton.
Is there a code so that if I enter a value in the textbox, then the code search my range until it found this value and return the corresponding value from the other column AND ALL THE FOLLOWING VALUES TILL IT COMES TO THE FIRST NON BLANK CELL IN THE FIRST COLUMN.
For example, If I enter "DDD" in the textbox, the first column in the listbox will show "DDD" and the second one will show 444, 555and 666 respectively.
This is the code I'm using, but when I enter "AAA" in the textbox, .end(xldown) goes to "DDD" and not "BBB". Is there a way to solve this ??
Thank u in advance.
Dim SearchTerm As String
Dim topCell As Range, BottomCell As Range
SearchTerm = TextBox1.Text
With Sheet1.Range("A:A")
Set topCell = .Find(SearchTerm, after:=.Cells(Rows.Count, 1), LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext, MatchCase:=False)
If topCell Is Nothing Then
MsgBox SearchTerm & " not found."
Else
Set BottomCell = Range(topCell.End(xlDown).Offset(-1, 0), .Cells(Rows.Count, 2).End(xlUp)).Cells(1, 2)
With ListBox1
.Clear
.List = Range(topCell, BottomCell).Value
End With
End If
End With
Use the code below as a reference to establish which cell is actually the bottom cell for the range of values. Let me know if you need help using it.
Sub DoTheThang()
Dim TopCell As Range
Dim BottomCell As Range
Dim SearchString As String
Dim rngUsed As Range
SearchString = "EEE"
Set TopCell = Range("A:A").Find(SearchString, Cells(1, 1))
Set BottomCell = TopCell
Set rngUsed = Sheet1.UsedRange
Do While BottomCell.Offset(1).Value = "" And Not Intersect(BottomCell, rngUsed) Is Nothing
Set BottomCell = BottomCell.Offset(1)
Loop
MsgBox TopCell.Address
MsgBox BottomCell.Address
End Sub
I have some VBA experience, I can read and understand the coding, but have problems finding the proper codes.
Now, I have a userform where by the user would key in his ID, excel would then open up the database and search and return the results of the cells beside the found ID. the results would be returned and overwrite label 1 and label 2. And when the user clicks on the "next" or "previous" button, the next or previous results would then overwrite both labels.
The code I have right now allows me to search for the locations of the found ID and output the location in a format such as ($A$2,$A$3,$A$4,$A$6). The problem is that I am not sure what is the right functions that can then break this into individual range that the "next" or "previous" button can then refer to.
Have added my code
Dim cell As Range
Dim bcell As Range
Dim foundat As String
Dim oRange As Range
Dim userid As String
Dim x As Long
Dim y As Long
Dim Prob As String
Dim ws As Worksheet
Set ws = Worksheets("OFI")
Set oRange = ws.Columns(1)
userid = txt_user.Text
Set cell = oRange.Find(what:=userid, after:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not cell Is Nothing Then
Set bcell = cell
foundat = cell.Address
Do
Set cell = oRange.FindNext(after:=cell)
If Not cell Is Nothing Then
If cell.Address = bcell.Address Then Exit Do
foundat = foundat & ", " & cell.Address
Else
Exit Do
End If
Loop
Else
msgbox userid & "not found"
Exit Sub
End If
capproblem_output.Caption = foundat
Exit Sub
You need to add two command buttons with name cmdNext & cmdPrev , label with name capproblem_output2 to run the below code. Copy the code to userform code section.
Public foundat As String
Private Sub cmdNext_Click()
capproblem_output.Caption = ActiveCell.Offset(1, 1)
capproblem_output2.Caption = ActiveCell.Offset(1, 1)
ActiveCell.Offset(1, 0).Select
End Sub
Private Sub cmdPrev_Click()
capproblem_output.Caption = ActiveCell.Offset(-1, 1)
capproblem_output2.Caption = ActiveCell.Offset(-1, 1)
ActiveCell.Offset(-1, 0).Select
End Sub
Private Sub CommandButton1_Click()
Main
End Sub
Sub Main()
Dim cell As Range
Dim bcell As Range
Dim oRange As Range
Dim userid As String
Dim x As Long
Dim y As Long
Dim Prob As String
Dim ws As Worksheet
Set ws = Worksheets("OFI")
Set oRange = ws.Columns(1)
userid = UserForm1.txt_user.Text
Set cell = oRange.Find(what:=userid, after:=Range("A1"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, searchdirection:=xlNext, MatchCase:=False)
If Not cell Is Nothing Then
Set bcell = cell
foundat = cell.Address
Do
Set cell = oRange.FindNext(after:=cell)
If Not cell Is Nothing Then
If cell.Address = bcell.Address Then Exit Do
foundat = foundat & ", " & cell.Address
Else
Exit Do
End If
Loop
Else
MsgBox userid & "not found"
Exit Sub
End If
capproblem_output.Caption = Range(foundat).Offset(0, 1)
capproblem_output2.Caption = Range(foundat).Offset(0, 1)
End Sub