Faster code for extracting data using Instr

[DavidSCowan]

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

 

[wigi]

Consider:

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

 tags when you post code on the forum. It makes the code formatted and readable.

 

[MickG]

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.

[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]

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

 tags when you post code on the forum. It makes the code formatted and readable.

 

[Peter_SSs]

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

 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]

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]

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.

[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]

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]

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]

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.