How to speed up code

[Dan]

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

 

[Mike H]

Dan,

One improvement would be to include

Application.screenupdating=false

your code

Application.screenupdating = true

Mike

 

[Dan]

Thanks Mike, acctually I have that but did not show it.

What I was thinking was a way to find the row number of the first occurance
of Item. Then I can start there instead of at the beginning.

If I can't do that I would write code that would check is Items is greater
than cell(a,b) then jump to cells(rowcount/2,b) and compare, if Item is less
split it in half on the bottom(1/4 row). If greater go to the 3/4 row. etc.
Then I may only loop 200 times instead of 20,000. I don't know if I'm clear
here. I've done it before but it was long ago.

DG

 

[dbKemp]

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

 

[Dan]

Thanks, Exactly what I was looking for.

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