How can I find data in sheet using VBA? - vba

Question

So I have workbook with sheets named Contacts and Help. In Help sheet I have Button which shows inputbox and asks "What client you would like to find?"
When I input name like Samuel Smith. I would like that VBA would go to Contacts sheet and find me Samuel Smith and offset to one column right and copy the Firm where Samuel Smith works. Then paste it to Help sheet and find next Samuel Smith. I would love to do this even if there were 50 Samuel Smith's in Contacts! Just don't know how to do this so any help is much appreciated!
Thank you all for your answers in advance.

Answer 1

Below are my custom function, that can find and return the result in Array.
From the find result you should able to solve your problem.
Hope this help !
Sub test()
'The result will be on Column C, because offset = 1
Dim nItem, Found As Variant
Found = iFind("Concatenate", Columns(2), 1)
For Each nItem In Found
MsgBox nItem
Next
End Sub
Function iFind(ByVal findText As String, ByVal nColumn As Range, ByVal offsetColumn As Single, _
Optional ByVal startRow As Single = 1, Optional ByVal caseSensitive As Boolean = False) As Variant
'Return Array of Range
'nColumn - Column to find
'offsetColumn - offset column to return
Dim WBD As Workbook
Dim WSD As Worksheet
Dim lastRow, tCount, nCount, nRow, nCol, N As Single
Dim nColRng, dataRng As Range
Dim compare As VbCompareMethod
Dim nArray As Variant
ReDim nArray(0)
Set WSD = nColumn.Parent
'Ensure only on column selected to consider lastRow
Set nColRng = nColumn.Columns(1)
nCol = nColRng.Column
'Get the lastRow
On Error Resume Next
lastRow = startRow
lastRow = nColRng.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
If lastRow < startRow Then lastRow = startRow
On Error GoTo 0
Set dataRng = Intersect(WSD.Range(WSD.Rows(startRow), WSD.Rows(lastRow)), nColRng)
tCount = Excel.Application.WorksheetFunction.CountIfs(dataRng, findText)
If tCount > 0 Then
nCount = 0
N = 0
Do While nCount < tCount
nRow = Excel.Application.Match(findText, dataRng, 0) + dataRng(1).Row - 1
If caseSensitive = True Then
compare = vbBinaryCompare
Else
compare = vbTextCompare
End If
'Add into array, only if matching case
If InStr(1, findText, WSD.Cells(nRow, nCol), compare) Then
ReDim Preserve nArray(N)
nArray(N) = WSD.Cells(nRow, nCol + offsetColumn)
N = N + 1
End If
nCount = nCount + 1
'Resize dataRng
Set dataRng = Intersect(WSD.Range(WSD.Rows(nRow + 1), WSD.Rows(lastRow)), nColRng)
Loop
End If
iFind = nArray
End Function

Answer 2

I worked on this hole night and now I know how to do this!
Option Explicit
'''''''
Dim Find_Inp As String
Dim Find As Variant
Dim Error_ As Integer
'''''''
Sub Test2()
On Error Resume Next
Sheet1.Select
Range("A8:G100").ClearContents
Find_Inp = InputBox("Please input Account!")
If Find_Inp = "" Then
Exit Sub
End If
MsgBox "This will take some time please wait."
Sheet2.Select
Call Macro1 'Sort macro
Call Find_Full
Exit Sub
End Sub
Function
Private Function Find_Full()
On Error GoTo ErrorHandler
'''''''
Dim Account_Column As Variant
Dim Result As Range, Result2 As Range
Dim LastAccount As Long
Dim NextAccount As Long
Dim Find_repeat As Integer
'''''''
Sheets("Contacts").Select
Account_Column = Range("G1").Select
Find = Cells.Find(What:=Find_Inp, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False).Activate
Find_repeat:
If Find = True Then
Set Result = ActiveCell
LastAccount = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row
NextAccount = LastAccount + 1
Result.Copy 'Where the name
Sheet1.Select
Range("C" & NextAccount).PasteSpecial xlPasteValuesAndNumberFormats
Result.Offset(0, -2).Copy 'Where the firm name is
Sheet1.Select
Range("C" & NextAccount).Offset(0, 1).PasteSpecial xlPasteValuesAndNumberFormats
Sheet2.Select
Result.Offset(0, -1).Copy 'Where the email is
Sheet1.Select
Range("C" & NextAccount).Offset(0, 2).PasteSpecial xlPasteValuesAndNumberFormats
Sheet2.Select
Result.Offset(0, 9).Copy 'Where the phone number
Sheet1.Select
Range("C" & NextAccount).Offset(0, -2).PasteSpecial xlPasteValuesAndNumberFormats
Sheet2.Select
Result.Offset(0, 10).Copy 'Where the work number is
Sheet1.Select
Range("C" & NextAccount).Offset(0, -1).PasteSpecial xlPasteValuesAndNumberFormats
Sheet2.Select
Result.Offset(0, 4).Copy 'Where the firm addres is
Sheet1.Select
Range("C" & NextAccount).Offset(0, 3).PasteSpecial xlPasteValuesAndNumberFormats
Sheet2.Select
Result.Offset(0, 5).Copy 'Where the title is
Sheet1.Select
Range("C" & NextAccount).Offset(0, 4).PasteSpecial xlPasteValuesAndNumberFormats
Error_ = 0
End If
Sheet2.Select
Result.Offset(1, 0).Select
Set Result2 = ActiveCell
If Result2 = Find_Inp Then
GoTo Find_repeat
Else
Sheet1.Select
Range("A1").Select
End If
ErrorHandler:
If Error_ = 1 Then
Sheet1.Select
Range("A1").Select
MsgBox "Account was not found! Try again."
End If
Error_ = 1
End Function
Sort Macro
Private Sub Macro1()
'
' Macro1 Macro
'
'
Dim Lastrow As Long
Lastrow = Sheet2.Cells(Rows.Count, 7).End(xlUp).Row
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Contacts").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Contacts").Sort.SortFields.Add Key:=Range("G1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Contacts").Sort
.SetRange Range("A2:AJ2106")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub