Speed up VBA using Countif, Index & Match

[Lifeson]

Hi all.

I had some great help recently which has spurred me on to learn more and more VBA however I have a problem with the code below taking about 15 minutes to complete and wonder if there is a more efficient way of returning the required data. Even if I turn off calculations, I need to calculate teh sheet afterward which still takes the same time... Any help or suggestions would be greatly appreciated.

I have about 150,000 rows of data (across 12 columns).

The range A:B is the source data. This contains the serial number and price of certain car parts. Since we have a number of suppliers of the same car parts. I need to return the range of prices for each car part in order that (later on), I can select the cheapest parts and then see which of the suppliers is consistently most expensive. Example of the table below:

ColumnA ColumnB ColumnC ColumnD ColumnE ColumnF ColumnG ColumnH ColumnI
CarPart Price Supplier CarPartRef Price1 Price2 Price3 Price4 Price5
000001a 136.20 JC Cars 000001a 136.20 142.36 137.88 122.99 N/A
000001a 142.36 GT Cars 0245211 36.42 32.33 35.28 32.10 32.99
000001a 137.88 Turbo Cars
000001a 122.99 Mack Cars
0245211 36.42 JT Motors
0245211 32.33 Glen & co
0245211 35.28 Amberside
0245211 32.10 Hull motors
0245211 32.99 Green Cars

I am using the following to return my price variances for each Car Part however it is taking about 15-20 minutes to complete:

Range("E2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COLUMN()-4<=COUNTIF(C1,RC4),INDEX(C2,MATCH(RC4,C1,0)+COLUMN()-5),"""")"


ActiveCell.AutoFill Range(ActiveCell, ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1))
Range("E2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False


Range("F2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COLUMN()-4<=COUNTIF(C1,RC4),INDEX(C2,MATCH(RC4,C1,0)+COLUMN()-5),"""")"


ActiveCell.AutoFill Range(ActiveCell, ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1))
Range("F2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COLUMN()-4<=COUNTIF(C1,RC4),INDEX(C2,MATCH(RC4,C1,0)+COLUMN()-5),"""")"


ActiveCell.AutoFill Range(ActiveCell, ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1))
Range("G2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("H2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COLUMN()-4<=COUNTIF(C1,RC4),INDEX(C2,MATCH(RC4,C1,0)+COLUMN()-5),"""")"


ActiveCell.AutoFill Range(ActiveCell, ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1))
Range("H2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False


Range("I2").Select
ActiveCell.FormulaR1C1 = _
"=IF(COLUMN()-4<=COUNTIF(C1,RC4),INDEX(C2,MATCH(RC4,C1,0)+COLUMN()-5),"""")"


ActiveCell.AutoFill Range(ActiveCell, ActiveCell.Offset(0, -1).End(xlDown).Offset(0, 1))

 

[Norie]

Where are the car prices coming from?

Are they on another sheet? Another range on the same sheet?

 

[Lifeson]

Where are the car prices coming from?

Are they on another sheet? Another range on the same sheet?

Hi Norrie, these are in Column A, B & C of Sheet1 - The data to be returned is on columns D:J

Column D is basically the list of car parts with duplicates removed.