# Speed Up Formula for +3000 rows

#### bayles

##### Board Regular
Hi,

I am trying to check to see if two cells in Sheets("CHECKING") or (ws2), correspond with values in Sheets("Category Hierarchy (5)") or ws3. In row 1 of ws3 there are "Departments" and below that department from row 2 onwards are categories and these categories are unique values to only one department.

The value in Cell.offset(0,-2) is the category and the value in cell.offset(0,-3) is the department. We need to make sure that the category in ws2 in the column of the matched department in ws3. i.e. make sure there is not a mismatched category to a department.

The following code works fine but it takes a long time to loop through all the cells in rng1.

Is there a quicker way to increase speed? See below for code and samples of data from both ws.
Code:
``````Sub test()

Dim rng, catrng As Range
Dim ws As Worksheet

Set ws2 = Sheets("CHECKING")
Set rng1 = Range(ws2.Cells(1, 6), ws2.Cells(1, 6).End(xlDown))

For Each cell In rng1
Set ws3 = Sheets("CATEGORY HIERARCHY (" & cell.Offset(0, -1).Value & ")")
If Not cell.Offset(0, 2) = 0 Or IsError(Application.Match(cell.Offset(0, -3).Value, ws3.Rows("1:1"), 0)) Then
ws2.Cells(i, 8) = "0"
Else
x = Application.WorksheetFunction.Match(cell.Offset(0, -3), ws3.Rows("1:1"))
Set catrng = Range(ws3.Cells(2, x), ws3.Cells(1000, x))
If IsError(Application.VLookup(cell.Offset(0, -2), catrng, 1, False)) Then
cell.Offset(0, 4) = "1"
Else
cell.Offset(0, 4) = "0"
End If
End If
Next cell

End Sub``````

Here is some sample data from ws2:
 Icy Hot Private Label Health & Beauty First Aid Essential Oils/Lotions 5 548 Icy HotPrivate LabelHealth & BeautyFirst Aid Essential Oils/Lotions5 0 0 0 Signature Home Private Label Household Products Toilet Cleaners 5 577 Signature HomePrivate LabelHousehold ProductsToilet Cleaners5 0 0 0 Signature Home Private Label General Merchandise Household Gloves 5 577 Signature HomePrivate LabelGeneral MerchandiseHousehold Gloves5 0 0 0 Crest Procter & Gamble Health & Beauty Toothbrush - Pwr 5 578 CrestProcter & GambleHealth & BeautyToothbrush - Pwr5 0 0 0 Soleil Other Mfr Health & Beauty Razors & Blades 5 602 SoleilOther MfrHealth & BeautyRazors & Blades5 0 0 0 Irish Spring Other Mfr Health & Beauty Liquid Soap 5 609 Irish SpringOther MfrHealth & BeautyLiquid Soap5 0 0 0 Ponds Unilever Health & Beauty Facial Tissues 5 613 PondsUnileverHealth & BeautyFacial Tissues5 0 0 0 Just For Men Other Mfr Health & Beauty Colourants 5 626 Just For MenOther MfrHealth & BeautyColourants5 0 0 0 Biotene GlaxoSmithKline Health & Beauty Toothpaste 5 662 BioteneGlaxoSmithKlineHealth & BeautyToothpaste5 0 0 0 Dentu-Crème GlaxoSmithKline Health & Beauty Denture Care 5 662 Dentu-CrèmeGlaxoSmithKlineHealth & BeautyDenture Care5 0 0 0 Love Beauty & Planet Unilever Health & Beauty Cream / Lotion 5 707 Love Beauty & PlanetUnileverHealth & BeautyCream / Lotion5 0 0 0 Motrin Other Mfr Health & Beauty Analgesics 5 711 MotrinOther MfrHealth & BeautyAnalgesics5 0 0 0 Bengay Other Mfr Health & Beauty Medicinal 5 711 BengayOther MfrHealth & BeautyMedicinal5 0 0 0 One A Day Bayer Health & Beauty Digestive Remedies 5 716 One A DayBayerHealth & BeautyDigestive Remedies5 0 0 0 Dove Other Mfr Health & Beauty Shamp, Cond & Treat 5 735 DoveOther MfrHealth & BeautyShamp, Cond & Treat5 0 0 0 Ajax Colgate Palmolive Household Products Dishwashing - Manual 5 779 AjaxColgate PalmoliveHousehold ProductsDishwashing - Manual5 0 0 0 Suavitel Colgate Palmolive Household Products Fabric Care 5 779 SuavitelColgate PalmoliveHousehold ProductsFabric Care5 0 0 0 Fabuloso Colgate Palmolive Household Products Fabric Care 5 779 FabulosoColgate PalmoliveHousehold ProductsFabric Care5 0 0 0 Murphys Other Mfr Health & Beauty Liquid Soap 5 779 MurphysOther MfrHealth & BeautyLiquid Soap5 0 0 0 Tylenol Johnson & Johnson Health & Beauty Medicinal 5 809 TylenolJohnson & JohnsonHealth & BeautyMedicinal5 0 0 0 Simply Sleep Other Mfr Health & Beauty Vitamins 5 813 Simply SleepOther MfrHealth & BeautyVitamins5 0 0 0 Nature Bounty Other Mfr Health & Beauty Vitamins 5 844 Nature BountyOther MfrHealth & BeautyVitamins5 0 1 0 Top Care Other Mfr Health & Beauty Digestive Remedies 5 896 Top CareOther MfrHealth & BeautyDigestive Remedies5 0 0 0 Duo Other Mfr Health & Beauty Cosmetics 5 902 DuoOther MfrHealth & BeautyCosmetics5 0 0 0 OGX Other Mfr Health & Beauty Liquid Soap 5 906 OGXOther MfrHealth & BeautyLiquid Soap5 0 0 0 Up & Up Private Label Health & Beauty Facial Tissues 5 930 Up & UpPrivate LabelHealth & BeautyFacial Tissues5 0 0 0

<colgroup><col width="64" span="10" style="width:48pt"> </colgroup><tbody>
</tbody>

Here the sample data from ws3:

<colgroup><col width="64" span="17" style="width:48pt"> </colgroup><tbody>
</tbody>

Last edited by a moderator:

#### =ODIN=

##### Active Member
Have you worked with arrays in VBA yet?

If not, that is what you should start researching.

Since excel 2007 and beyond, cycling through cells in a range has been extremely slow, so the best practice is to load a range of cells to an array, all at once. Do whatever work needs to be done within excel's memory without touching cells on a sheet. Then finally load back to the sheet the output all at once.

Below is a simple demo of how that might work.

Code:
``````Sub arrExample()
'load array in and spit array out

arr = Range("a1:b3") 'load range into 2d array 'arr becomes a 2 dimensional array loaded with the range's values

'processing the range could happen here

Range("c4:d6") = arr  'export the 2d array back to a different range

End Sub``````

Last edited:

#### bayles

##### Board Regular
Hi Odin,

I am completely self taught in VBA and I have been googling and looking at videos on how to accomplish this but it is all going a bit over my head.

Would you mind giving me some more detail in your answer and using the formulas I have above.

I would be very appreciative if you could.

Thanks

#### Fluff

##### MrExcel MVP, Moderator
Code:
``````Sub bayles()
Dim CatAry As Variant
Dim Dic As Object
Dim r As Long, c As Long
Dim Cl As Range

Application.ScreenUpdating = False

CatAry = Sheets("Category Hierarchy (5)").Range("A1").CurrentRegion.Value2
Set Dic = CreateObject("scripting.dictionary")

For c = 2 To UBound(CatAry, 2)
For r = 2 To UBound(CatAry)
Dic(CatAry(1, c))(CatAry(r, c)) = Empty
Next r
Next c

With Sheets("Checking")
For Each Cl In .Range("C2", .Range("C" & Rows.Count).End(xlUp))
If Not Dic.Exists(Cl.Value) Then
Cl.Offset(, 7).Value = 1
ElseIf Not Dic(Cl.Value).Exists(Cl.Offset(, 1).Value) Then
Cl.Offset(, 7).Value = 1
Else
Cl.Offset(, 7).Value = 0
End If
Next Cl
End With
End Sub``````

#### bayles

##### Board Regular
Thanks so much Fluff.

That was great. I'll try to learn from this code as to how to implement arrays. I can usually fluke my way through it eventually.

Cheers

#### Fluff

##### MrExcel MVP, Moderator
You're welcome & thanks for the feedback