On Oct 31, 10:32 am, "Dan" wrote:
I am trying to find item codes that have different suffixes on the for
example color.

Data
A B C D E
F
ITEMS TO FIND ITEMS ITEMS FOUND VARIATIONS
ACT 1111 ACT 1234 ACT 1237 ACT
1237-BK
ACT 1235 ACT 1235 ACT 1237 ACT
1237-BR
ACT 1235-GR ACT 1236 ACT 1237 ACT 1237-GR
ACT 1237 ACT 1237 ACT 1237 ACT
1237-WT
ACT 1239 ACT 1237-BK
ACT 1237-BR
ACT 1237-GR
ACT 1237-WT
ACT 1238
ACT 1239

What I am trying to do is find the items in column A that exist in column C
that have suffixes and put the item from A in column E and its corisponding
item (with suffix) in column F.

Here is my code:

Sub Run_Report()
Dim x As Long
Dim Item As Variant

Range("a2").Select
x = 2
While Cells(x, 1) < ""
Item = Cells(x, 1)
Find_Variations Item
x = x + 1
Wend

End Sub
Sub Find_Variations(Item As Variant)
Dim y, z As Long

y = 2 ' track where we are in column C
z = 2 ' track where we are in columns E & F
While Cells(y, 3) < "" 'Look for Item in column C
If Item = Left(Cells(y, 3), Len(Item)) Then
If Item < Cells(y, 3) Then ' we don't want to find exact matchs
Cells(z, 5) = Item
Cells(z, 6) = Cells(y, 3)
z = z + 1
End If
End If
y = y + 1
Wend

End Sub

The problem is I have 3,000 items in column A and 40,000 items in column C.
So the code takes a long time. I wanted to use VLOOKUP but it will not find
all variations. Is there any other options? Any ideas on speeding up the
code?

By the way the example above Columns E and F are the actual result that I
want.

DG

Use constants when you have a lot of loops
Avoid variants when you know what object is eg Excel.range
The .Find, .FindNext can really speed things up
Try something like this:

Sub Run_Report()
Dim rLookUp As Excel.Range 'Column of items to find
Dim rFindIn As Excel.Range 'Column of items
Dim rFind As Excel.Range 'Any given cell in rLookUp
Dim rOutput As Excel.Range 'Two columns of output

'These assume that there is column between following ranges and no
spaces
'You may need to specify these differently
Set rLookUp = Range("A2").CurrentRegion
Set rLookUp = rLookUp.Offset(1, 0).Resize(rLookUp.Rows.Count - 1)
Set rFindIn = Range("c2").CurrentRegion
Set rFindIn = rFindIn.Offset(1, 0).Resize(rFindIn.Rows.Count - 1)
Set rOutput = Range("E2:F2")

For Each rFind In rLookUp.Cells
If rFind.Value < vbNullString Then
Find_Variations rFind.Value, rFindIn, rOutput
End If
Next

End Sub

Sub Find_Variations(ByRef FindThis As String, ByRef FindIn As
Excel.Range, ByRef OutputRange As Excel.Range)
Dim rCell As Excel.Range 'Any given cell that contains FindThis
Dim sFirstAddress As String 'Address of first cell found. Need to
check this so don't go into continuous loop

'See if FindThis is in items
Set rCell = FindIn.Find(what:=FindThis,
after:=FindIn.Cells(FindIn.Rows.Count, 1), LookIn:=xlValues,
Lookat:=xlPart)
'If not, exit sub
If Not rCell Is Nothing Then
'if found, save address
sFirstAddress = rCell.Address
Do
'Your Checks
'Is left of item = FindThis
If InStr(1, rCell.Value, FindThis) = 1 Then
'If same length, then FindThis = item, so skip
If Len(FindThis) < Len(rCell.Value) Then
'Output data
OutputRange(OutputRange.Rows.Count, 1) = FindThis
OutputRange(OutputRange.Rows.Count, 2) = rCell.Value
'Resize output range for next output
Set OutputRange =
OutputRange.Resize(OutputRange.Rows.Count + 1)
End If
End If
'See if another cell meets criteria
Set rCell = FindIn.FindNext(rCell)
'Loop until nothing found or address is first address found
Loop While Not rCell Is Nothing And rCell.Address <
sFirstAddress
End If
End Sub