find match occurrences and copy to sheet - excel

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

Related

How do I get the Cell Address from a Variable VBA

I created a variable oldPassword which is populated using a VLookup.
I am trying to get now the cell address from that result but nothing seem to work.
Dim oldPassword As String
oldPassword = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value, Worksheets("Employees").Range("A:B"), 2, False)
You should break the task into steps
Get a reference to the cell containing the search value
Use that reference to get the required value and address
Sub Demo
Din rSearch As Range
Dim rUser as Range
Dim rPassword As Range
Dim idx As Variant
Set rSearch = Worksheets("Employees").Range("A:B")
idx = Application.Match(Me.ComboBox1.Value, rSearch.Columns(1), 0)
If Not IsError(idx) Then
Set rUser = rSearch.Cells(idx, 1)
Set rPassword = rUser.Cells(1, 2)
' get the result
oldPassword = rPassword.Value2
' get the address
Debug.Print rPassword.Address
End If
End Sub
I would prefer using .Find as #Andreas suggested but then that is my personal preference.
Option Explicit
Sub Sample()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Employees")
Dim aCell As Range
Set aCell = ws.Columns(1).Find(What:=ComboBox1.Value, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
Dim oldPassword As String
If Not aCell Is Nothing Then
With aCell.Offset(, 1)
'~~> Do what you want with that cell
oldPassword = .Value2
MsgBox .Address
End With
Else '<~~ Optional
MsgBox ComboBox1.Value & " not found!"
End If
End Sub

How to Find, cut, paste and erase with VBA code

I am new on VBA and i dont know almost nothing.
I've been trying a code to find a value entered in a inputbox "CXRG", find on sheet "ESTOQUEV" cut all the line and paste on sheet "SAIDA" (down from another values) and erase the blank line from "ESTOQUEV"
Someone could help me?
Private Sub CommandButton1_Enter()
linha = Worksheets("SAIDA").Range("A100000").End(xlUp).Row + 1
Worksheets("SAIDA").Cells(linha, 1) = CXOS.Value
Worksheets("SAIDA").Cells(linha, 2) = CXRG.Value
CXOS.Text = ""
CXRG.Text = ""
SendKeys "{TAB}", True ' Envia TAB para pular par o inicio.
Call refresh.Macro8
End Sub
you have to try this code (run just findAndPast())
Sub findAndPast()
Dim shttoFind As Worksheet
Dim shttoPast As Worksheet
Dim LastRowOffind As Long
Dim inBox As String
Dim cell As Range
Set shttoFind = Worksheets("ESTOQUEV")
Set shttoPast = Worksheets("SAIDA")
Call Find_Last
LastRowOffind = shttoPast.Cells(shttoPast.Rows.Count, "A").End(xlUp).Row + 1
ActiveCell.EntireRow.Copy
shttoPast.Activate
shttoPast.Cells(LastRowOffind, 1).PasteSpecial
shttoFind.Activate
ActiveCell.EntireRow.Delete
End Sub
Sub Find_Last()
Dim FindString As String
Dim Rng As Range
FindString = InputBox("Enter a Search value")
If Trim(FindString) <> "" Then
With Sheets("ESTOQUEV").Range("A:C")
Set Rng = .Find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not Rng Is Nothing Then
Application.Goto Rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub

Loop through cells and display a message if a value is not found

I have a macro that loops through cells of one sheet, looks for that value in another sheet, and then highlights the row if they match. I'd like to add a message box that would pop up if a matching value is not found. I know this is a simple problem, but I'm having trouble figuring out in which loop to put my booleans.
Sub MarkXfer_noX()
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim j As Integer
Dim ProdCI As String
Dim found As Boolean
Dim intRowCount As Integer
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
For j = 2 To rng2.Rows.count 'from row 2 to the end
If rng2.Cells(j, 2) = ProdCI Then 'if the ProdCI in column B matches the one we picked,
Call FillCell(j) 'call a sub in a different module and give it our current row
found = True
Else
found = False
End If
Next
Next
If found = False Then
MsgBox (ProdCI & " not found") 'Display a message if one of the items wasn't found on the main page. Currently has an error where the last one in the list always pops up.
Else
End If
End Sub
Right now it always shows a msgbox with the last value in the range no matter what.
Thanks all, here is the updated working code using the Find function
Sub MarkXfer_Find()
'Re-tooled to use the .Find function instead of looping through each
Dim rng As Range
Dim rng2 As Range
Set rng = Worksheets("Transferred Routings").UsedRange
Dim i As Integer
Dim ProdCI As String
Dim intRowCount As Integer
Dim intRowCount2 As Integer
Dim aCell As Range
intRowCount = Sheets("Transferred Routings").UsedRange.Rows.count
For i = 2 To intRowCount
If rng.Cells(i, 1) <> "" Then ProdCI = rng.Cells(i, 1) 'get the ProdCI number from column A if not blank
Worksheets("All_ProCI").Activate 'activate main page
Set rng2 = Worksheets("All_ProCI").UsedRange 'select a range on the main page
intRowCount2 = Worksheets("All_ProCI").UsedRange.Rows.count
'use the Find function to put a value in aCell
Set aCell = rng2.Range("B1:B" & intRowCount2).Find(What:=ProdCI, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'MsgBox ProdCI & " found"
Call FillCell(aCell.row)
Else 'If aCell is blank display msgbox
MsgBox "ProdCI """ & ProdCI & """ not found"
End If
Next
End Sub

Replace method and changing format?

I'm using vba method Replace, and I need to change every "/" to ",". This looks like a simple task so I use:
ActiveWorkbook.Worksheets(2).Cells.Replace What:="_/_", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=True, _
ReplaceFormat:=True
The problem is when one of cells has value like:
04_/_2018
And the result is:
4,2018
instead of:
04,2018
All of my cells in this workbook has text formating before and after aplying the code. My guess is that Excel in a process is changing the format to general for a moment and it cut offs not necessary for a number left zero.
I've tried to bypass this issue by changing parameters of the method (none of this worked) and changing the decimal separator from "," to ".". This helped when using find and replace by hand from Excel, but when I record it and try to use as Macro it doesn't work. What can I do to prevent Excel from cutting off zeros in this scenarios?
If you want 04,2018 then use .Find/.FindNext then replace+reconstruct the value before placing in the cell.
Is this what you are trying?
Sub Sample()
Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim ExitLoop As Boolean
Dim SearchString As String
On Error GoTo Whoa
Set ws = Worksheets("Sheet1")
Set oRange = ws.UsedRange
SearchString = "_/_"
Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
If Left(aCell.Value, 1) = 0 Then
aCell.Value = "'" & Replace(aCell.Value, SearchString, ",")
Else
aCell.Value = Replace(aCell.Value, SearchString, ",")
End If
Do While ExitLoop = False
Set aCell = oRange.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
If Left(aCell.Value, 1) = 0 Then
aCell.Value = "'" & Replace(aCell.Value, SearchString, ",")
Else
aCell.Value = Replace(aCell.Value, SearchString, ",")
End If
Else
ExitLoop = True
End If
Loop
Else
MsgBox SearchString & " not Found"
End If
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Screenshot
The leading zeroes are automatically removed in Excel by default. Thus 04,2014 is changed to 4,2014. A way to work around this is to format the cells as Text, adding this line before the Replace():
ActiveWorkbook.Worksheets(2).Cells.NumberFormat = "#"
Formatting to Text has a lot of unpleasant changes, e.g. the text goes to the left and Excel does not recognize the dates/numbers by default.
This is a simple sample of the code, changing 1 cell:
Sub TestMe()
ActiveWorkbook.Worksheets(1).Cells.NumberFormat = "General"
Range("B5") = "05_2018"
ActiveWorkbook.Worksheets(1).Cells.NumberFormat = "#"
Range("B5") = Replace(Range("B5"), "_", ".")
End Sub
Formatting to text can work like this, for bigger, unknown ranges:
Sub TestMe()
Worksheets(1).Cells.NumberFormat = "General"
Range("A1:B15") = "05_2018"
Dim findRange As Range
Set findRange = Worksheets(1).Cells.Find("_")
Dim myCell As Range
If Not findRange Is Nothing Then
For Each myCell In findRange
myCell.Replace "_", ","
Next myCell
End If
End Sub

Search for a string in a Worksheet using VBA

I am trying to search for a particular string "ERROR" in all the worksheets in the workbook and make it bold and color the found cell red.
I am able to parse through each worksheet. I am not able to use the Find function of VBA.
Here's an example of using Find and formatting the found cells
Sub FindERROR()
Dim SearchString As String
Dim SearchRange As Range, cl As Range
Dim FirstFound As String
Dim sh As Worksheet
' Set Search value
SearchString = "ERROR"
Application.FindFormat.Clear
' loop through all sheets
For Each sh In ActiveWorkbook.Worksheets
' Find first instance on sheet
Set cl = sh.Cells.Find(What:=SearchString, _
After:=sh.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not cl Is Nothing Then
' if found, remember location
FirstFound = cl.Address
' format found cell
Do
cl.Font.Bold = True
cl.Interior.ColorIndex = 3
' find next instance
Set cl = sh.Cells.FindNext(After:=cl)
' repeat until back where we started
Loop Until FirstFound = cl.Address
End If
Next
End Sub
if you are searching in excel vba you can use following simple code with InStr command.
Private Sub CommandButton1_Click()
Dim RowNum As Long
RowNum = 1
Do Until Sheets("Data").Cells(RowNum, 1).Value = ""
If InStr(1, Sheets("Data").Cells(RowNum, 2).Value, TextBox1.Value, vbTextCompare) > 0 Then
On erro GoTo next1
ListBox1.AddItem Sheets("Data").Cells(RowNum, 1).Value
ListBox1.List(ListBox1.ListCount - 1, 1) = Sheets("Data").Cells(RowNum, 2).Value
End If
next1:
RowNum = RowNum + 1
Loop
End Sub
you can download example file from here
How about this:
If Not WorkBook.Sheets("Sheet1").Range("A1:Z150").Find("Cookie") Is Nothing
MsgBox "Found a Cookie"
End If

Resources