Need VBA For Loops with Conditions

[chesterrae]

Hi All,

Currently I have 10K+ rows of data which increase every month that's why I need a vba code that will return "Tier 2" and "Tier 3" in column (D) Tier.


Here are the conditions:
1) Tier 2, if there are 2 or more unique Order ID within the last 12 months per Account Name. (using Today() function)
2) Tier 3, if there are only 1 unique Order ID within the last 12 months per Account Name. (using Today() function).
3) Else Leave it blank.

Below is the sample data:

Excel 2007 32 bit

	A​	B​	C​	D​
1​	Order ID	Account Name	Order Date	Tier
2​	18JBP5008	Robert Downey Jr	10/1/2018​	Tier 3
3​	18JBP5008	Robert Downey Jr	10/1/2018​	Tier 3
4​	18JAK0336	Chris Evans	10/1/2018​	Tier 2
5​	18JAK0336	Chris Evans	10/1/2018​	Tier 2
6​	18JAK0335	Chris Evans	10/1/2018​	Tier 2
7​	18JAP2322	Chris Hemsworth	1/1/2017​
8​	18JAP2322	Chris Hemsworth	11/21/2017​	Tier 3
9​	18JAP2322	Chris Hemsworth	12/21/2017​	Tier 3
10​	18JAP2322	Chris Hemsworth	10/1/2018​	Tier 3
11​	18JAN1058	Scarlett Johansson	10/1/2018​	Tier 3
12​	18JDM5411	Jeremy Renner	8/2/2017​
13​	18JDM5411	Samuel Jackson	8/10/2017​
14​	18JDM5412	Samuel Jackson	10/2/2018​	Tier 3
15​	18JBM3812	Mark Ruffalo	5/2/2017​
16​	18JBM3813	Mark Ruffalo	6/3/2017​
17​	18JBM3814	Mark Ruffalo	10/3/2018​	Tier 3

Sheet: Sheet1

Thank you so much in advance!

 

[Tim_Excel_]

Public Function UniquesInArray(ArrayOfValues) As String
' Copyright © 2009 Extra Mile Data, www.extramiledata.com.
' Edited by Tim_Excel_ for MrExcel.com
On Error GoTo Err_DuplicatesInArray


    Dim intUB As Integer
    Dim intElem As Integer
    Dim intLoop As Integer
    Dim intCount As Integer
    Dim varValue
    Dim varLoop
    Dim strResults As String
    
    intUB = UBound(ArrayOfValues)
    Uniques = intUB + 1
    strResults = ""
    For intElem = 0 To intUB
        intCount = 0
        varValue = ArrayOfValues(intElem)
        If Not IsNull(varValue) Then
            For intLoop = 0 To intUB
                varLoop = ArrayOfValues(intLoop)
                If Not IsNull(varLoop) And Not intElem = intLoop Then
                    If varLoop = varValue Then
                        Uniques = Uniques - 1
                        GoTo nintElem
                    End If
                End If
            Next intLoop


        End If
nintElem:
    Next intElem


        UniquesInArray = Uniques




Exit_DuplicatesInArray:
    On Error Resume Next
    Exit Function
   
Err_DuplicatesInArray:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "DuplicatesInArray()"
    DuplicatesInArray = ""
    Resume Exit_DuplicatesInArray
End Function



Sub Tier2or3 ()
Dim arr as Variant

With ThisWorkbook.Sheets("Sheet1")
LRow = .Cells(.Rows.Count, "A").End(xlUp).Row

newname:
NameVal = .Range("B" & i).Value
For each cell in Range("B" & i & ":B" & LRow)
[INDENT]If cell.value = NameVal Then
[/INDENT]
[INDENT=2]ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = .Range(cell.address)Offset(-1,0).Value
[/INDENT]
[INDENT]Else[/INDENT]
[INDENT=2]i = cell.row
For each C in .Range("D2:D" LRow)[/INDENT]
[INDENT=3]If .Cells(C.Row, "B").Value = NameVal Then[/INDENT]
[INDENT=4]If UniquesInArray(arr)>1 And CDate(.Cells(C.Row, "C").Value) > DateAdd("m", -12, Date()) Then .Cells(C.Row, "D").Value = "Tier 3"[/INDENT]
[INDENT=4]If UniquesInArray(arr)=1 And CDate(.Cells(C.Row, "C").Value) > DateAdd("m", -12, Date()) Then .Cells(C.Row, "D").Value = "Tier 2"[/INDENT]
[INDENT=3]End if[/INDENT]
[INDENT=2]Next C
if i = LRow then goto exitloop
GoTo newname

[/INDENT]
[INDENT]End If[/INDENT]
Next cell
exitloop:

This took me way longer than expected... Hope it works!