Faster code for extracting data using Instr

DavidSCowan

Board Regular
Joined
Jun 7, 2009
Messages
78
Hi There

I am using InstrRev to extract items from around 200,000 cells in Col A. The problem is that the macro takes around 3 hours to run. I am relatively inexperienced in VBA so I was wondering if there is a way to make the code run faster.

Example cells in Col A are:

ADMIRATION SYBN OIL MRGR STICK 16 OZ
LUDWIG DAIRY BTR UNSL SOLID 7.14 OZ
NU-MAID VGTB OIL ASSRTD COMMON CO SLTD TUB 1 CT
CANOLA HARVEST CNL OIL CTNS OIL SPRD TUB 33 PCT FWR CLR 16 OZ
AMUL BTR SLTD SOLID 17.64 OZ

The purpose of the macro is to write the sizes or weights in the Col A cells to Col B and the measure (e.g. OZ for ounces) to Col C. So the output from the cells above would be:

Col B
16
7.14
1
16
17.64

Col C
OZ
OZ
CT
OZ
OZ

The code is:

Sub Instr_Simple_2()
finalrow = Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False

For i = 2 To finalrow
If InStrRev(Cells(i, 1).Value, " OZ") <> 0 Then

position1 = InStrRev(Cells(i, 1), "OZ")
position2 = InStrRev(Cells(i, 1), " ", position1 - 2)
Gap = position1 - position2 - 2
Cells(i, 2) = Mid(Cells(i, 1), position2 + 1, Gap)
Cells(i, 3).Value = "OZ"

ElseIf InStrRev(Cells(i, 1).Value, " CT") <> 0 Then
position1 = InStrRev(Cells(i, 1), "CT")
position2 = InStrRev(Cells(i, 1), " ", position1 - 2)
Gap = position1 - position2 - 2
Cells(i, 2) = Mid(Cells(i, 1), position2 + 1, Gap)
Cells(i, 3).Value = "CT"
Else
End If

Next i
Application.ScreenUpdating = True

End Sub

How can I make the code run faster?

Can someone help please. Thank you

With kind regards

David
 

Some videos you may like

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

wigi

Well-known Member
Joined
Jul 10, 2006
Messages
7,958
Office Version
  1. 365
Platform
  1. Windows
  2. Mobile
  3. Web
Consider:

Code:
Sub Instr_Simple_2_Wigi()
    
    sq = Range("A2", Range("A" & Rows.Count).End(xlUp).Offset(, 2))
    For i = 1 To UBound(sq, 1)
        If InStrRev(sq(i, 1), " CT") Or InStrRev(sq(i, 1), " OZ") Then
            st = Split(sq(i, 1))
            sq(i, 2) = st(UBound(st) - 1)
            sq(i, 3) = st(UBound(st))
        End If
    Next
    Range("A2", Range("A" & Rows.Count).End(xlUp).Offset(, 2)) = sq

End Sub

Thank you also to take out the time to use
Code:
 tags when you post code on the forum. It makes the code formatted and readable.
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
If the data required is always the last two bits of information in each row then try this:-
I tried your code on 40K rows , it took just over a minute
The code below took about 1 sec.

Code:
[COLOR=navy]Sub[/COLOR] MG10Nov14
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] ray
[COLOR=navy]Dim[/COLOR] nRay
[COLOR=navy]Dim[/COLOR] t
 t = Timer
[COLOR=navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim nnray(1 To Rng.Count, 1 To 2)
nRay = Application.Transpose(Rng)
    [COLOR=navy]For[/COLOR] n = 1 To UBound(nRay)
        ray = Split(nRay(n), " ")
        nnray(n, 1) = ray(UBound(ray) - 1)
        nnray(n, 2) = ray(UBound(ray))
    [COLOR=navy]Next[/COLOR] n
Range("B1").Resize(Rng.Count, 2) = nnray
MsgBox Timer - t
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 

DavidSCowan

Board Regular
Joined
Jun 7, 2009
Messages
78
Hi Wigi

Absolutely brilliant - it ran in under 3 seconds!

There is a snag though. There are cells that have strings of numbers at the end e.g.
ALCAM CREAMERY BTR UNSL SOLID 16 OZ 00003
ELLE & VIRE BTR UNSL SOLID 7 OZ 1640219137

And of course these screw up the result.

I am still puzzling out how your code works but can it to accommodate this?

Thanks again for such a great and quick reply.

David
PS I am afraid I don't understand "Thank you also to take out the time to use
Code:
 tags when you post code on the forum. It makes the code formatted and readable.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,926
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

There is a snag though. There are cells that have strings of numbers at the end e.g.
ALCAM CREAMERY BTR UNSL SOLID 16 OZ 00003
ELLE & VIRE BTR UNSL SOLID 7 OZ 1640219137



PS I am afraid I don't understand "Thank you also to take out the time to use
Code:
 tags when you post code on the forum. It makes the code formatted and readable.[/QUOTE]Are there aother units of measurement besides OZ and CT? If so could we have a list?

Re CODE tags: Notice how the code from wigi and MickG is indented. That makes it easy to see where For...Next and If...End If blocks of text start and end. Yours is not like that so it is harder to read and debug. My signature block gives some informatiuon about posting formatted code.
 

DavidSCowan

Board Regular
Joined
Jun 7, 2009
Messages
78
Hi MickG

Your's is brilliant too. It processed the 197,000 cells in less than .7 seconds!

Unfortunately I misled you all slightly because it isn't true that "the data required is always the last two bits of information in each row

There are cells that have strings of numbers at the end e.g.
ALCAM CREAMERY BTR UNSL SOLID 16 OZ 00003
ELLE & VIRE BTR UNSL SOLID 7 OZ 1640219137

And of course these screw up the result.

I am still puzzling out how your code works but can it to accommodate this?

Thanks again for such a great and quick reply.

David
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841

ADVERTISEMENT

This takes slighty longer but caters for there either being an extra word/number at the end or Not being a Word/number at the end.
Code:
[COLOR="Navy"]Sub[/COLOR] MG10Nov35
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] ray
[COLOR="Navy"]Dim[/COLOR] nRay
[COLOR="Navy"]Dim[/COLOR] t
[COLOR="Navy"]Dim[/COLOR] pos [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
 t = Timer
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim nnray(1 To Rng.Count, 1 To 2)
nRay = Application.Transpose(Rng)
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(nRay)
        ray = Split(nRay(n), " ")
        pos = IIf(ray(UBound(ray)) = "OZ" Or ray(UBound(ray)) = "CT", UBound(ray), UBound(ray) - 1)
        nnray(n, 1) = ray(pos - 1)
        nnray(n, 2) = ray(pos)
    [COLOR="Navy"]Next[/COLOR] n
Range("B1").Resize(Rng.Count, 2) = nnray
MsgBox Timer - t
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

DavidSCowan

Board Regular
Joined
Jun 7, 2009
Messages
78
Hi Peter SSs

Thank you very much for your reply. In this case there aren't other units of measurement apart from "OZ" and "CT" however my attempt at code was a first step towards creating a more general utility that could work from a longer list which of course was stymied because the macro I had written only dealing with two units was taking so long to run. Any ideas as to how this could be done would be appreciated.

I am rather kicking myself too because I have rather misled the board by not pointing out that sometimes there are strings of numbers at the end of some of the cells. (My InstrRev solution was able to cope with this.)

ALCAM CREAMERY BTR UNSL SOLID 16 OZ 00003
ELLE & VIRE BTR UNSL SOLID 7 OZ 1640219137

Have you any ideas as to how these can be coped with?

On the Code tag point I understand now. The code as written in the vba code window is indented but when I copy it into the message board the indentations are lost. I will make sure I restore them in future.

Once again thank you for your reply.

David
 

DavidSCowan

Board Regular
Joined
Jun 7, 2009
Messages
78
Hi Mick G

This works great however it stops at row 64,632! Your first macro covered the distance to row 195,705. Why should this be do you think?

David
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
47,926
Office Version
  1. 365
Platform
  1. Windows
Hi Mick G

This works great however it stops at row 64,632! Your first macro covered the distance to row 195,705. Why should this be do you think?

David
I think that may be a limitation with Application.Transpose.
I'm sure Mick can get the data into an array another way.
 

Watch MrExcel Video

Forum statistics

Threads
1,122,215
Messages
5,594,883
Members
413,947
Latest member
gizmolucy

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top