I need your help,
I can't seem to get the next or previous buttons to work with the .FindNext and FindPrevious functions of excel.
My aim is to create a user form where the user can use the next and prev buttons to go back and fourth between the found matches of "test". I thought that by globalizing the variable foundCell, I might be able to accomplish this, but I was epically wrong.
Dim foundCell
Private Sub btnSearch_Click()
With Sheet1
Set foundCell = .Cells.find(What:="test", After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Bingo"" found in row " & foundCell.Row)
form1.location.Value = Cells(foundCell.Row, 1).Value
Else
MsgBox ("Bingo not found")
End If
End Sub
Private Sub btnNext_Click()
foundCell.FindNext
form1.location.Value = Cells(foundCell.Row, 1).Value
End Sub
Private Sub btnPrev_Click()
foundCell.FindPrevious
form1.location.Value = Cells(foundCell.Row, 1).Value
End Sub
I would take your search routine and move it into a sub routine. Then you can just call it by passing in a few params. like the starting cell to search from and which direction to go.
Private Sub btnSearch_Click()
dosearch Cells(1, 1), Excel.xlNext
End Sub
Private Sub btnNext_Click()
dosearch foundCell, Excel.xlNext
End Sub
Private Sub btnPrev_Click()
dosearch foundCell, Excel.xlPrevious
End Sub
Sub dosearch(r As Range, whichWay As Integer)
With Sheet1
Set foundCell = .Cells.Find(What:="test", After:=r, _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=whichWay, MatchCase:=False, SearchFormat:=False)
End With
If Not foundCell Is Nothing Then
MsgBox ("""Bingo"" found in row " & foundCell.Row)
form1.Location.Value = Cells(foundCell.Row, 1).Value
Else
MsgBox ("Bingo not found")
End If
End Function
Related
I'm using visual basic to create a checkout system in an excel sheet. The sheet will be filled with information for a project, each of the projects requires that we send out a kit. This excel sheet will allow for a barcode to be scanned, when this happens, it checks for puts an "out" time. When that barcode is scanned again it puts an "in" time. The issue I'm having is that if that barcode is scanned a third time, it will only update the out time.
How do I set it up where it will see that an "in" and "out" time have been recorded and thus go the next blank cell in the row and add the barcode + new "in" or "out" time. Any help would be greatly appreciated!
This is the code I am using.
Code for on the worksheet
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B2")) Is Nothing Then
Application.EnableEvents = False
Call inout
Application.EnableEvents = True
End If
End Sub
code for the macro
Sub inout()
Dim barcode As String
Dim rng As Range
Dim rownumber As Long
barcode = Worksheets("Sheet1").Cells(2, 2)
Set rng = Sheet1.Columns("a:a").Find(What:=barcode, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If rng Is Nothing Then
ActiveSheet.Columns("a:a").Find("").Select
ActiveCell.Value = barcode
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Date & " " & Time
ActiveCell.NumberFormat = "m/d/yyyy h:mm AM/PM"
Worksheets("Sheet1").Cells(2, 2) = ""
Else
rownumber = rng.Row
Worksheets("Sheet1").Cells(rownumber, 1).Select
ActiveCell.Offset(0, 2).Select
ActiveCell.Value = Date & " " & Time
ActiveCell.NumberFormat = "m/d/yyyy h:mm AM/PM"
Worksheets("Sheet1").Cells(2, 2) = ""
End If
Worksheets("Sheet1").Cells(2, 2).Select
End Sub
All this goes in the worksheet code module:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("B2")) Is Nothing Then
inout 'use of Call is deprecated
End If
End Sub
Sub inout()
Dim barcode As String
Dim rng As Range
Dim newRow As Boolean
barcode = Me.Cells(2, 2)
'find the *last* instance of `barcode` in ColA
Set rng = Me.Columns("A").Find(What:=barcode, after:=Me.Range("A1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
'figure out if we need to add a new row, or update an existing one
If rng Is Nothing Then
newRow = True 'no matching barcode
Else
'does the last match already have an "in" timestamp?
If Len(rng.Offset(0, 2).Value) > 0 Then newRow = True
End If
If newRow Then
Set rng = Me.Cells(Me.Rows.Count, "A").End(xlUp).Offset(1, 0)
rng.Value = barcode
SetTime rng.Offset(0, 1) 'new row, so set "out"
Else
SetTime rng.Offset(0, 2) 'existing row so set "in"
End If
Me.Cells(2, 2).Select
End Sub
'set cell numberformat and set value to current time
Sub SetTime(c As Range)
With c
.NumberFormat = "m/d/yyyy h:mm AM/PM"
.Value = Now
End With
End Sub
I'm trying to paste the enire row of information to the next available row but I keep getting errors about not having the Rows(lastrow +1, 1).EntireRow.Paste written correctly. Please let me know how I can perform that action correctly.
Private Sub CommandButton1_Click()
Dim myValue As String
myEmp = InputBox("Search for an employee by last name")
Range("B3").Value = myEmp
With Sheet7
Range("B:B").Select
Set Row = Selection.Find(What:=myEmp, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
Row.EntireRow.Copy
End With
Worksheets("Employee Reports").Activate
Dim lastrow As Long
lastrow = Range("A65536").End(xlUp).Row
Rows(lastrow + 1, 1).EntireRow.Paste
End Sub
Private Sub Workbook_Open()
Application.EnableEvents = False
Worksheets("Sheet3").Range("A4:A20").Value = ""
End Sub
Private Sub CommandButton1_Click()
Dim myValue As String
myEmp = InputBox("Search for an employee by last name")
ActiveSheet.Range("B3").Value = myEmp
Dim lastrow As Long
lastrow = Worksheets("Employee Reports").Range("A65536").End(xlUp).Row
With Sheet7
Dim rw As Range
Set rw = .Range("B:B").Find(What:=myEmp, After:=.Range("B1"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not rw Is Nothing Then
rw.EntireRow.Copy Worksheets("Employee Reports").Cells(lastrow + 1, 1)
Else
MsgBox myEmp & " Not Found in Range"
End If
End With
End Sub
I have a search box that auto opens when the file is started requesting the target value. I have tried many times to write something that will hide all rows above and below the value once found, with no avail.
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
Set Rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
Unload Me
End Sub
I would like to search for EMPLID 12345, return only that row (including the header on Row 1, with all other rows hidden.
Add an autofilter.
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
Set Rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
.autofilter
.autofilter field:=1, criteria1:=EMPLID
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
Unload Me
End Sub
just plain use of Autofilter():
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
.AutoFilter field:=1, Criteria1:=EMPLID
If WorksheetFunction.Subtotal(103, .Cells) = 1 Then ' if only header row filtered -> no match found
MsgBox "Nothing found"
.Parent.AutoFilterMode = False ' remove AutoFilter and show all data
End If
End With
Unload Me
End Sub
BTW I'd suggest you some little enhancements:
limit the searching range to the actual data extensions, instead of the whole column (some 1 million row)
Don't use Unload Me inside a UserForm code. Adopt Hide.Me and move Unload Me to the Userform calling sub (the one where you place some With New MyUserform statement or the likes)
like follows:
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data")
With .Range("E1", .Cells(.Rows.Count, "E").End(xlUp))
.AutoFilter field:=1, Criteria1:=EMPLID
If WorksheetFunction.Subtotal(103, .Cells) = 1 Then ' if only header row filtered -> no match found
MsgBox "Nothing found"
.Parent.AutoFilterMode = False ' remove AutoFilter and show all data
End If
End With
End With
Me.Hide
End Sub
I like the autofilter answer just posted. But a more-literal answer that actually hides the rows, except row 1 and the one where 'Rng' is, goes like this:
Sub tst()
Dim rng As Range, bottom As Range
Set rng = [D3] ' Just example data
rng.Activate ' put cursor on rng
' Assumes Column A has data, otherwise use column with Rng in it
Set bottom = Range("A" & Rows.Count).End(xlUp) ' finds last row in A with any data in it
If rng.Row > 2 Then Range(Rows(2), Rows(rng.Row - 1)).Hidden = True ' Hide all rows above RNG
If rng.Row < bottom.Row Then Range(Rows(rng.Row + 1), Rows(bottom.Row)).Hidden = True ' Hide rows below
End Sub
Another simple way to accomplish your task.
Private Sub Summary_Click()
Dim EMPLID As String, cl As Range
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data")
For Each cl In .Range("E2", .Range("E" & .Rows.Count).End(xlUp))
If Not cl.Value = EMPLID Then
cl.EntireRow.Hidden = True
End If
Next cl
End With
End Sub
Try
Sub test()
Dim EMPLID As String
Dim rngDB As Range, Rng As Range, rngU As Range
Dim Ws As Worksheet
Dim strAddress As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
Set Ws = Sheets("Tracking Data")
With Ws
Set rngDB = .Range("e1", .Range("e" & Rows.Count).End(xlUp))
End With
With rngDB
.EntireRow.Hidden = False
Set Rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
strAddress = Rng.Address
Do
If rngU Is Nothing Then
Set rngU = Rng
Else
Set rngU = Union(rngU, Rng)
End If
Set Rng = .FindNext(Rng)
Loop While Rng.Address <> strAddress
End If
End With
If rngU Is Nothing Then
MsgBox "Nothing found"
Else
rngDB.EntireRow.Hidden = True
rngU.EntireRow.Hidden = False
End If
End Sub
Find vs Parent
To not cramp your style, I've only removed the arguments SearchDirection and MatchCase because they were using default parameters and I've added the 'Parent' part which is referring to the worksheet (Tracking Data).
Private Sub Summary_Click()
Dim EMPLID As String
EMPLID = Application.InputBox("Enter Your Employee Number", "Employee Number")
With Sheets("Tracking Data").Range("E:E")
Set rng = .Find(What:=EMPLID, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows)
If Not rng Is Nothing Then
With .Parent
.Cells(2, 1).Resize(rng.Row - 2).EntireRow.Hidden = True
.Cells(rng.Row + 1, 1).Resize(.Rows.Count - rng.Row) _
.EntireRow.Hidden = True
End With
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
Unload Me
End Sub
I have created a userform and one of the commandbuttons launches another userform in which data can be entered into. This data is then added to a table in a worksheet, the userform is then unloaded and the user is returned to the original userform. The error occurs when the data is meant to be entered into the worksheet. This userform works perfectly on its own, but when it is launched from the first userform, this is when the error occurs.
Private Sub CommandButton1_Click()
'check all fields are filled
Dim nextRow As Integer
Dim nextCell As String
If Len(Trim(ComboBox1.Value)) = 0 Then
MsgBox "All feilds must be filled"
Exit Sub
End If
If Len(Trim(TextBox1.Value)) = 0 Then
MsgBox "All feilds must be filled"
Exit Sub
End If
If Len(Trim(TextBox2.Value)) = 0 Then
MsgBox "All feilds must be filled"
Exit Sub
End If
'Check if supplier ID already exists
Dim FindString As String
Dim Rng As Range
FindString = TextBox1.Value
If Trim(FindString) <> "" Then
With Sheet4.Range("B:B")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, False
MsgBox "Sorry Bro, " & FindString & " already exists!"
Exit Sub
Else
FindString = TextBox2
If Trim(FindString) <> "" Then
With Sheet4.Range("D:D")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, False
MsgBox "Sorry Bro, the Ordering Details you entered:" & vbNewLine & _
"'" & FindString & "'" & vbNewLine & _
"Already exists in our Database!" & vbNewLine & _
"U wanna check ur data?"
Exit Sub
End If
End With
End If
End If
End With
End If
'enter supplier ID into sheet
Sheet4.Activate
nextRow = ActiveSheet.Range("B2", Range("B2").End(xlDown)).Count
nextCell = Cells(nextRow + 2, 2).Activate
'this is where the error occurs
ActiveCell.Value = TextBox1.Value
ActiveCell.Offset(0, 1).Value = ComboBox1.Value
ActiveCell.Offset(0, 2).Value = TextBox2.Value
Sheet2.Activate
Unload Me
End Sub
I'm not sure why it doesn't work because personally I avoid the use of "Activate". Maybe you can try if this works:
'Previous code that worked fine
nextRow = ActiveSheet.Range("B2", Range("B2").End(xlDown)).Count
With ActiveSheet.Cells(nextRow + 2, 2)
.Value = TextBox1.Value
.Offset(0, 1).Value = ComboBox1.Value
.Offset(0, 2).Value = TextBox2.Value
End With
Sheet2.Activate
Unload Me
End Sub
Hope this does the job! (Note that this is my first answer so I'm very open to feedback)
I want the macro to look for same value as in B2. And then copy the value from range D2:G2 to the found range. In this example D9:G9.
Thank you in advance :D.
I tried:
Sub Button1_Click()
Dim myRng1, myRng2 As Range, cell As Range
Set myRng1 = Range("A4:A1000")
Set myRng2 = Range("D2:G2")
myRng2.Select
Selection.Copy
For Each cell In myRng1
If Range("A2") = Range("A" & cell.Row) Then Range("D" & cell.Row).Select
ActiveSheet.Paste
Next cell
End Sub
Sub Find()
Dim Findcode As String
Dim Rng As Range
Range("A2:F2").Select
Selection.Copy
Findcode = Sheets("Sheet1").Range("a2").Value
If Trim(Findcode) <> "" Then
With Sheets("Sheet1").Range("A4:A60000")
Set Rng = .Find(What:=Findcode, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
ActiveSheet.Paste
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub