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

 

[MickG]

I don't really know
Does your data change in some way at that point, if so send an example of around that point.
You could also check the number of rows in code. If you open the code window and step through the code by clickiing "F8" repeatedly, when you get to the lines below hold the curser over "Rng.count" or "Ubound (nRay)" this will give you the number of rows the code is looking at.

ReDim nnray(1 To Rng.Count, 1 To 2)
nRay = Application.Transpose(Rng)
    For n = 1 To UBound(nRay)

 

[DavidSCowan]

There aren't any changes in the cells around 64,632 but UBound(nRay) is set at 64,632 which must be the reason the macro stops there.

Peter suggested that there may be a limitation on Application.Transpose is there another way of getting data into the array?

 

[MickG]

He may well be right , but why would it then work on the other code, being xl2003, I'm not able to give it real test.
If you do the same "Rng.count"/"Ubound(nRay)" check with the First code what do you get.

 

[DavidSCowan]

Mick

Apologies the first macro stopped at 64,632 as well I thought it had done the whole lot but it hadn't. And the explanation is that Ubound(nRay) is set at 64,632 for the first macro too.

Rgds

David

 

[wigi]

Do you experience the same cut off at 64,632 in my macro?

 

[MickG]

Its all al bit strange to me !!
If you want to Remove the "Application.transpose" you can try using the code as below.
NB:- I filled my Entire sheet less the last row and this returned a row count of "65535" for "Rng.count/Ubound(nRay)" as expected !!!

[COLOR="Navy"]Sub[/COLOR] MG10Nov32
[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 = Rng
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(nRay)
        ray = Split(nRay(n, 1), " ")
        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]

That's brilliant you've done it - the 195,700 rows in 1.59 seconds!
Thank you very much for sticking at this
With kind regards
David

 

[MickG]

Pleased you got it working, and pleased I've also learned something about the apparent limitations of "Application.transpose".
Regards Mick

 

[DavidSCowan]

Hi Mick

It's great you got something out of solving my problem and thank you again for that.

If ever there was an example of what good code can do it was apparent yesterday where a task that took 3 hours to run was accomplished in 1.6 seconds!


If possible I would like to learn as much as possible from your code but unfortunately I don't fully understand how it works. Is there any way you could annotate the code to explain how each bit is working? I am finding that I have got somewhat stuck climbing up the learning curve and am not progressing to a new level largely because I need smart code explained. I will of course do my homework on arrays and things like the Split function.

With kind regards

David

 

[MickG]

Have a look at this:-
When you've got to grips with this have a look at "Wigi's" code it a bit more subtle that mine and quite interesting.

[COLOR="Navy"]Sub[/COLOR] MG11Nov18
[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="Green"][B]This line sets the Data in column "A" to the Object/Range variable "Rng"[/B][/COLOR]
'[COLOR="Green"][B]This is a faily standard bit of code[/B][/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
'[COLOR="Green"][B]''''''''''''''[/B][/COLOR]
'[COLOR="Green"][B]Re-dimension an array (for Results), to the size of the Range "Rng" with 2 columns[/B][/COLOR]
'[COLOR="Green"][B]"Redim" because we don't know the size of the array at the declaration stage.[/B][/COLOR]
ReDim nnray(1 To Rng.Count, 1 To 2)
'[COLOR="Green"][B]'''''''''''''''''[/B][/COLOR]
'[COLOR="Green"][B]Set "Rng" to Variant Array "nRay", I could have Accomplished this at the "Set Rng" line[/B][/COLOR]
'[COLOR="Green"][B]and saved a bit of duplication.[/B][/COLOR]
nRay = Rng
  '[COLOR="Green"][B]''''''''''''''''''''''''''[/B][/COLOR]
    '[COLOR="Green"][B]Loop through array "nRay"[/B][/COLOR]
    [COLOR="Navy"]For[/COLOR] n = 1 To UBound(nRay)
      '[COLOR="Green"][B]As the array "nRay" is an array version of the range "Rng"[/B][/COLOR]
      '[COLOR="Green"][B]"n" will refer to the row number[/B][/COLOR]
      '[COLOR="Green"][B]''''''''''''''''''''[/B][/COLOR]
        '[COLOR="Green"][B]Use "split" function to divide Words/Number(By Spaces in text) into an array "Ray"[/B][/COLOR]
        Ray = Split(nRay(n, 1), " ")
        '[COLOR="Green"][B]''''''''''''''''''''''''''[/B][/COLOR]
        '[COLOR="Green"][B]Use "iif" function to determine position of "OZ" or "CT"[/B][/COLOR]
       '[COLOR="Green"][B] Means:- If the last value in the array "Ray" = "OZ" or "CT" then "pos" (Postion of OZ or CT) is Last or One from last[/B][/COLOR]
        pos = IIf(Ray(UBound(Ray)) = "OZ" Or Ray(UBound(Ray)) = "CT", UBound(Ray), UBound(Ray) - 1)
        '[COLOR="Green"][B]''''''''''''''''''''''''''''[/B][/COLOR]
        '[COLOR="Green"][B]Place the Value found and its "Units" into column (1) and (2) of array "nnRay"[/B][/COLOR]
        nnray(n, 1) = Ray(pos - 1)
        nnray(n, 2) = Ray(pos)
    [COLOR="Navy"]Next[/COLOR] n
'[COLOR="Green"][B]'''''''''''''''''''''''''''''''''''[/B][/COLOR]
'[COLOR="Green"][B]Place the array "nnRay") back on the sheet[/B][/COLOR]
Range("B1").Resize(Rng.Count, 2) = nnray
MsgBox Timer - t
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick