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
[Table="width:, class:head"][tr=bgcolor:#E0E0F0][th] [/th][th]

A​

[/th][th]

B​

[/th][th]

C​

[/th][th]

D​

[/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

1​

[/td][td]Order ID[/td][td]Account Name[/td][td]Order Date[/td][td]Tier[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

2​

[/td][td]18JBP5008[/td][td]Robert Downey Jr[/td][td]

10/1/2018​

[/td][td]Tier 3[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

3​

[/td][td]18JBP5008[/td][td]Robert Downey Jr[/td][td]

10/1/2018​

[/td][td]Tier 3[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

4​

[/td][td]18JAK0336[/td][td]Chris Evans[/td][td]

10/1/2018​

[/td][td]Tier 2[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

5​

[/td][td]18JAK0336[/td][td]Chris Evans[/td][td]

10/1/2018​

[/td][td]Tier 2[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

6​

[/td][td]18JAK0335[/td][td]Chris Evans[/td][td]

10/1/2018​

[/td][td]Tier 2[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

7​

[/td][td]18JAP2322[/td][td]Chris Hemsworth[/td][td]

1/1/2017​

[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

8​

[/td][td]18JAP2322[/td][td]Chris Hemsworth[/td][td]

11/21/2017​

[/td][td]Tier 3[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

9​

[/td][td]18JAP2322[/td][td]Chris Hemsworth[/td][td]

12/21/2017​

[/td][td]Tier 3[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

10​

[/td][td]18JAP2322[/td][td]Chris Hemsworth[/td][td]

10/1/2018​

[/td][td]Tier 3[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

11​

[/td][td]18JAN1058[/td][td]Scarlett Johansson[/td][td]

10/1/2018​

[/td][td]Tier 3[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

12​

[/td][td]18JDM5411[/td][td]Jeremy Renner[/td][td]

8/2/2017​

[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

13​

[/td][td]18JDM5411[/td][td]Samuel Jackson[/td][td]

8/10/2017​

[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

14​

[/td][td]18JDM5412[/td][td]Samuel Jackson[/td][td]

10/2/2018​

[/td][td]Tier 3[/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

15​

[/td][td]18JBM3812[/td][td]Mark Ruffalo[/td][td]

5/2/2017​

[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

16​

[/td][td]18JBM3813[/td][td]Mark Ruffalo[/td][td]

6/3/2017​

[/td][td][/td][/tr]


[tr=bgcolor:#FFFFFF][td=bgcolor:#E0E0F0]

17​

[/td][td]18JBM3814[/td][td]Mark Ruffalo[/td][td]

10/3/2018​

[/td][td]Tier 3[/td][/tr]
[/table][Table="width:, class:grid"][tr][td]Sheet: Sheet1[/td][/tr][/table]




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!