Using The Range Find Method
The Range Find Method allows the user to search for one or more occurrances of a variable within a range. It is useful when you want to search for items in all the rows and columns of a range. The example below locates multiple occurrances of a particular cell value and copies that cell value plus the next three cells to the right in the same row to a separate sheet.
Program Code
Option Explicit
Dim C As Range
Dim rngCopyRange As Range
Dim FirstAddress As String
Dim shtSheet1 As Worksheet
Dim shtSheet2 As Worksheet
Dim lngSheet2LastRow As Long
' ***************************************************************
' Find All SA64 Values And Copy That Cell + Three Cells To the
' Right To Sheet 2
' ***************************************************************
Public Sub FindSA64()
Set shtSheet1 = Sheets("Sheet1")
Set shtSheet2 = Sheets("Sheet2")
' ***************************************************************
' Assume Column A Always Has Data
' ***************************************************************
lngSheet2LastRow = shtSheet2.Cells(Rows.Count, "A").End(xlUp).Row
' ***************************************************************
' Change Sheet1 Range to Your Requirements Or Make It Dynamic
' A1:K500 Is Only For Demo Purposes
' ***************************************************************
With shtSheet1.Range("A1:K500")
Set C = .Find("SA64", LookIn:=xlValues)
If Not C Is Nothing Then
FirstAddress = C.Address
Call CopyData
Set C = .FindNext(C)
Do While Not C Is Nothing And C.Address <> FirstAddress
Call CopyData
Set C = .FindNext(C)
Loop
End If
End With
End Sub
Public Sub CopyData()
lngSheet2LastRow = lngSheet2LastRow + 1
Set rngCopyRange = Range(C, C.Offset(0, 3))
rngCopyRange.Copy shtSheet2.Cells(lngSheet2LastRow, 1)
End Sub
' *************************************************************************
' The Following Similar Example Searches For Multiple Values
' *************************************************************************
Option Explicit
Dim C As Range
Dim rngCopyRange As Range
Dim FirstAddress As String
Dim shtSheet1 As Worksheet
Dim shtSheet2 As Worksheet
Dim lngSheet2LastRow As Long
Dim strStringToFind() As Variant
Dim intNumberOfSearchItems As String
Dim i As Integer
' ***************************************************************
' Find All SA64 Values And Copy That Cell + Three Cells To the
' Right To Sheet 2
' ***************************************************************
Public Sub FindSA64()
' ***************************************************************
' Change "2" to the Number Of Items To Be Searched
' ***************************************************************
ReDim strStringToFind(1 To 2)
strStringToFind(1) = "SA59"
strStringToFind(2) = "SA65"
intNumberOfSearchItems = UBound(strStringToFind)
Set shtSheet1 = Sheets("Sheet1")
Set shtSheet2 = Sheets("Sheet2")
' ***************************************************************
' Assume Column A Always Has Data
' ***************************************************************
lngSheet2LastRow = shtSheet2.Cells(Rows.Count, "A").End(xlUp).Row
' ***************************************************************
' Change Sheet1 Range to Your Requirements Or Make It Dynamic
' A1:K500 Is Only For Demo Purposes
' ***************************************************************
For i = 1 To intNumberOfSearchItems
With shtSheet1.Range("A1:K500")
Set C = .Find(strStringToFind(i), LookIn:=xlValues)
If Not C Is Nothing Then
FirstAddress = C.Address
Call CopyData
Set C = .FindNext(C)
Do While Not C Is Nothing And C.Address <> FirstAddress
Call CopyData
Set C = .FindNext(C)
Loop
End If
End With
Next i
End Sub
Private Sub CopyData()
lngSheet2LastRow = lngSheet2LastRow + 1
Set rngCopyRange = Range(C, C.Offset(0, 3))
rngCopyRange.Copy shtSheet2.Cells(lngSheet2LastRow, 1)
End Sub
' **********************************************************************************************
' Another Technique for Range Find
' **********************************************************************************************
Sub SearchForValues()
' ***********************************************
' Search One Column Only But Compare a Second
' Columns Values To The Title
' ***********************************************
Dim SiteID As Long
Dim Name As String
' ***********************************************
' Search For SiteID = 7, Title="Sales Manager"
' On Sheet 2
' ***********************************************
SiteID = 7
Name = GetName(SiteID, "Sales Manager")
End Sub
Public Function GetName(ByVal SiteID As Integer, ByVal Title As String) As String
Dim c As Variant
Dim FirstAddr As Variant
Dim RowTitle As String
Dim wkbMyWorkbook As Workbook
Dim wksSheet2 As Worksheet
' ***********************************************
' Set Workbook and Worksheet Variables
' ***********************************************
Set wkbMyWorkbook = ThisWorkbook
Set wksSheet2 = wkbMyWorkbook.Sheets("Sheet2")
' ***********************************************
' Define Column Contents
' ***********************************************
Const SiteIDCol = "A"
Const TitleCol = "B"
Const NameCol = "C"
GetName = ""
' ***********************************************
' Do The Search
' ***********************************************
With wksSheet2
Set c = .Columns(SiteIDCol).Find(what:=SiteID, _
LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
FirstAddr = c.Address
Do
RowTitle = .Range(TitleCol & c.Row).Value
If RowTitle = Title Then
GetName = .Range(NameCol & c.Row)
Exit Do
End If
Set c = .Columns(SiteIDCol).FindNext(after:=c)
Loop While Not c Is Nothing And c.Address <> FirstAddr
End If
End With
End Function
