VBA Macros For Upgrade Or Downgrade Status Based On Multiple Conditions

H

HECGroups

Board Regular
Joined
Jan 16, 2012
Messages
164
Hello Again,

I have 13 networks and 7 classes. I need to categorized the status whenever any class of network change. I am looking for a VBA Macros which can give me the out put as shown below.

Explanation with example below.

Ex 1: In column C I have status From Class A To Class B & From NW A To NW AA for the status will be Class Downgrade in column D, Network Downgrade in column E, Dash (-) in column F and Class Downgrade & Network Downgrade in column G

Ex 2: In column C I have status From Class A To Class C / Add To Rabia / From NW A To NW CC for the status will be Class Downgrade in column D, Network Downgrade in column E, Plan Upgrade in column F and Class Downgrade, Plan Upgrade & Network Downgrade in column G



Excel 2012
A
B
1
Network
Class
2
VIP+
Class VIP+
3
VIP
Class VIP
4
AAA
Class A
5
AA
Class B
6
A
Class C+
7
BBB
Class C
8
BB
Class R
9
B
10
C+
11
CCC
12
CC
13
R
14
Rabia

<tbody>
</tbody>
Sheet4​

Excel 2012
C
D
E
F
G
1
Class From To Grade Change
Class Status
Network Status
Plan
Status
2
Add To Rabia
-
-
Downgrade
Plan Downgrade
3
Form Class C To Class C+ & From NW CC To NW C+
Upgrade
Upgrade
-
Class Upgrade & Network Upgrade
4
From Class A To Class B
Downgrade
-
-
Class Downgrade
5
From Class A To Class B & From NW A To NW AA
Downgrade
Downgrade
-
Class Downgrade & Network Upgrade
6
From Class A To Class B & From NW B To NW BB
Downgrade
Upgrade
-
Class Downgrade & Network Upgrade
7
From Class A To Class C / Add To Rabia / From NW A To NW CC
Downgrade
Downgrade
-
Class Downgrade & Network Downgrade
8
From Class A To Class C+
Downgrade
-
-
Class Downgrade & Network Downgrade
9
From Class A To Class C+ / From NW C+ To NW BB
Downgrade
Upgrade
-
Class Downgrade & Network Upgrade
10
From Class A To Class VIP
Upgrade
Upgrade
-
Class Upgrade & Network Upgrade
11
From Class B To Class A & From NW BB To NW A
Upgrade
Upgrade
-
Class Upgrade & Network Upgrade
12
From Class B To Class A / From NW BBB To NW AA / From NW AA To NW AAA / From AAA NW To AA NW
Upgrade
Upgrade / Upgrade / Downgrade
-
Class Upgrade, Network Upgrade, Network Upgrade & Network Downgrade
13
From Class B To Class C
Downgrade
-
-
Class Downgrade
14
From Class B To Class C / Add To Rabia
Downgrade
-
Downgrade
Class Downgrade & Plan Downgrade
15
From Class B To Class C / From Class C To Class C+ / From Class C+ To Class C
Downgrade / Upgrade / Downgrade
-
-
Class Downgrade, Class Upgrade & Class Downgrade
16
From Class B To Class C+
Downgrade
-
-
Class Downgrade
17
From Class B To Class C+
Downgrade
-
-
Class Downgrade
18
From Class B To Class C+ & From NW CCC To NW C+
Downgrade
Upgrade
-
Class Downgrade & Network Upgrade
19
From Class B To Class C+ & From NW CCC To NW C+
Downgrade
Upgrade
-
Class Downgrade & Network Upgrade
20
From Class B To Class C+ / From Class C+ To Class C & Add To Rabia
Downgrade / Downgrade
-
Downgrade
Class Downgrade, Class Downgrade & Plan Downgrade
21
From Class B To Class VIP
Upgrade
-
-
Class Upgrade
22
From Class C To Class A
Upgrade
-
-
Class Upgrade
23
From Class C To Class B
Upgrade
-
-
Class Upgrade
24
From Class C To Class B / From Class B To Class C / From NW B To NW CCC
Upgrade / Downgrade
Downgrade
-
Class Upgrade / Class Downgrade Network Downgrade
25
From Class C To Class C+
Upgrade
-
-
Class Upgrade Network
26
From Class C To Class C+ & From NW CCC To NW C+
Upgrade
Downgrade
-
Class Upgrade & Network Downgrade
27
From Class C To Class C+ & From NW CCC To NW CC
Upgrade
Downgrade
-
Class Upgrade & Network Downgrade
28
From Class C To Class C+ & Removed From Rabia / From C+ NW To CC NW
Upgrade
Downgrade
Upgrade
Class Upgrade, Network Downgrade & Plan Upgrade
29
From Class C To Class C+ / Add to NW CCC, NW CC, Class C & Add To Rabia
Upgrade
Downgrade
Downgrade
Class Upgrade, Network Downgrade & Plan Downgrade
30
From Class C To Class C+ / From Class C+ To Class C
Upgrade / Downgrade
-
-
Class Upgrade & Class Downgrade
31
From Class C To Class C+ / From NW CC To NW CCC
Upgrade
Upgrade
-
Class Upgrade & Network Upgrade
32
From Class C To Class C+ / From NW CCC To NW C+
Upgrade
Downgrade
-
Class Upgrade & Network Downgrade
33
From Class C To Class C+ / From NW CCC To NW CC
Upgrade
Downgrade
-
Class Upgrade & Network Downgrade
34
From Class C+ To Class A & From C+ NW To A NW
Upgrade
Upgrade
-
Class Upgrade & Network Upgrade
35
From Class C+ To Class B & From NW C+ To NW B
Upgrade
Upgrade
-
Class Upgrade & Network Upgrade
36
From Class C+ To Class B / From Class B To Class C
Upgrade / Downgrade
-
-
Class Upgrade & Class Downgrade
37
From Class C+ To Class B / From Class B To Class C / From A NW To C+ NW
Upgrade / Downgrade
Downgrade
-
Class Upgrade, Class Downgrade & Network Downgrade
38
From Class C+ To Class C
Upgrade
-
-
Class Upgrade Network
39
From Class C+ To Class C / Add To Rabia / From NW CCC To NW CC
Upgrade
Downgrade
Downgrade
Class Upgrade, Network Downgrade & Plan Downgrade
40
From Class C+ To Class C / Remove From Rabia
Downgrade
-
Upgrade
Class Downgrade & Plan Upgrade
41
From Class VIP To Class A
Downgrade
-
-
Class Downgrade
42
From NW AA To NW VIP
-
Upgrade
-
Network Upgrade
43
From NW B To NW BB
-
Upgrade
-
Network Upgrade
44
From NW B To NW C+
-
Downgrade
-
Network Downgrade
45
From NW BB To NW CCC & Add To Rabia
-
Downgrade
Downgrade
Network Downgrade & Plan Downgrade
46
From NW BBB To NW AA
-
Upgrade
-
Network Upgrade
47
From NW C+ To NW B
-
Upgrade
-
Network Upgrade
48
From NW C+ To NW CC
-
Downgrade
-
Network Downgrade
49
From NW C+ To NW CC & Add To Rabia
-
Downgrade
Downgrade
Network Downgrade & Plan Downgrade
50
From NW CC To NW C+
-
Upgrade
-
Network Upgrade
51
From NW CCC To NW C+
-
Upgrade
-
Network Upgrade
52
From NW CCC To NW CC
-
Downgrade
-
Network Downgrade
53
From NW CCC To NW CC & Add to Rabia
-
Downgrade
Downgrade
Network Downgrade & Plan Downgrade
54
From NW VIP To NW AA
-
Downgrade
-
Network Downgrade
55
From NW VIP+ To NW BBB
-
Downgrade
-
Network Downgrade
56
Remove From Rabia
-
-
Upgrade
Plan Upgrade

<tbody>
</tbody>
Sheet3​
 
Last edited:

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
Got the solution HERE

Code: 
Option Explicit

Sub StatusUpdates()
Dim LR As Long, mainARR As Variant, Rw As Long, BackupARR As Variant
Dim smallARR As Variant, s As Long, minARR As Variant, mLow As Long, mHigh As Long, Cnt As Long

On Error GoTo ErrorHandling

With ActiveSheet
    LR = .Range("C" & .Rows.Count).End(xlUp).Row
    ReDim BackupARR(1 To LR, 1 To 1)
    BackupARR = .Range("C1:C" & LR).Value
    .Range("C2:C" & LR).Replace " / ", ","
    .Range("C2:C" & LR).Replace " & ", ","
    .Range("C2:C" & LR).Replace "From ", ""
    .Range("C2:C" & LR).Replace "Form ", ""
    .Range("C2:C" & LR).Replace "Removed", "Remove"
    .Range("C2:C" & LR).Replace "Remove Rabia", "Remove From Rabia"
    .Range("D2:G" & LR).ClearContents
    ReDim mainARR(1 To LR, 1 To 6)
    mainARR = .Range("C1:H" & LR).Value

    For Rw = 2 To LR
        If InStr(mainARR(Rw, 1), ",") > 0 Then
            smallARR = Split(mainARR(Rw, 1), ",")
            For s = LBound(smallARR) To UBound(smallARR)
                If UCase(Trim(smallARR(s))) = "REMOVE FROM RABIA" Then
                    If mainARR(Rw, 4) <> "" Then
                        mainARR(Rw, 4) = mainARR(Rw, 4) & " / " & "Upgrade"
                    Else
                        mainARR(Rw, 4) = "Upgrade"
                    End If
                    mainARR(Rw, 6) = mainARR(Rw, 6) + 1
                ElseIf UCase(Trim(smallARR(s))) = "ADD TO RABIA" Then
                    If mainARR(Rw, 4) <> "" Then
                        mainARR(Rw, 4) = mainARR(Rw, 4) & " / " & "Downgrade"
                    Else
                        mainARR(Rw, 4) = "Downgrade"
                    End If
                    mainARR(Rw, 6) = mainARR(Rw, 6) + 1
                ElseIf InStr(smallARR(s), "Class") > 0 Then
                    minARR = Split(smallARR(s), " To ")
                    mLow = WorksheetFunction.Match(Trim(minARR(0)), Sheets("Lists").Range("Classes"), 0)
                    mHigh = WorksheetFunction.Match(Trim(minARR(1)), Sheets("Lists").Range("Classes"), 0)
                    If mLow > mHigh Then
                        If mainARR(Rw, 2) <> "" Then
                            mainARR(Rw, 2) = mainARR(Rw, 2) & " / " & "Upgrade"
                        Else
                            mainARR(Rw, 2) = "Upgrade"
                        End If
                    Else
                        If mainARR(Rw, 2) <> "" Then
                            mainARR(Rw, 2) = mainARR(Rw, 2) & " / " & "Downgrade"
                        Else
                            mainARR(Rw, 2) = "Downgrade"
                        End If
                    End If
                    mainARR(Rw, 6) = mainARR(Rw, 6) + 1
                ElseIf InStr(smallARR(s), "NW") > 0 Then
                    minARR = Split(smallARR(s), " To ")
                    mLow = WorksheetFunction.Match(Trim(minARR(0)), Sheets("Lists").Range("Networks"), 0)
                    mHigh = WorksheetFunction.Match(Trim(minARR(1)), Sheets("Lists").Range("Networks"), 0)
                    If mLow > mHigh Then
                        If mainARR(Rw, 3) <> "" Then
                            mainARR(Rw, 3) = mainARR(Rw, 2) & " / " & "Upgrade"
                        Else
                            mainARR(Rw, 3) = "Upgrade"
                        End If
                    Else
                        If mainARR(Rw, 3) <> "" Then
                            mainARR(Rw, 3) = mainARR(Rw, 2) & " / " & "Downgrade"
                        Else
                            mainARR(Rw, 3) = "Downgrade"
                        End If
                    End If
                    mainARR(Rw, 6) = mainARR(Rw, 6) + 1
                End If
            Next s
        Else
            If UCase(Trim(mainARR(Rw, 1))) = "REMOVE FROM RABIA" Then
                If mainARR(Rw, 4) <> "" Then
                    mainARR(Rw, 4) = mainARR(Rw, 4) & " / " & "Upgrade"
                Else
                    mainARR(Rw, 4) = "Upgrade"
                End If
                mainARR(Rw, 6) = mainARR(Rw, 6) + 1
                GoTo NextPart
            End If
            If UCase(Trim(mainARR(Rw, 1))) = "ADD TO RABIA" Then
                If mainARR(Rw, 4) <> "" Then
                    mainARR(Rw, 4) = mainARR(Rw, 4) & " / " & "Downgrade"
                Else
                    mainARR(Rw, 4) = "Downgrade"
                End If
                mainARR(Rw, 6) = mainARR(Rw, 6) + 1
                GoTo NextPart
            End If
            If InStr(mainARR(Rw, 1), "Class") > 0 Then
                minARR = Split(mainARR(Rw, 1), " To ")
                mLow = WorksheetFunction.Match(Trim(minARR(0)), Sheets("Lists").Range("Classes"), 0)
                mHigh = WorksheetFunction.Match(Trim(minARR(1)), Sheets("Lists").Range("Classes"), 0)
                If mLow > mHigh Then
                    If mainARR(Rw, 2) <> "" Then
                        mainARR(Rw, 2) = mainARR(Rw, 2) & " / " & "Upgrade"
                    Else
                        mainARR(Rw, 2) = "Upgrade"
                    End If
                Else
                    If mainARR(Rw, 2) <> "" Then
                        mainARR(Rw, 2) = mainARR(Rw, 2) & " / " & "Downgrade"
                    Else
                        mainARR(Rw, 2) = "Downgrade"
                    End If
                End If
                mainARR(Rw, 6) = mainARR(Rw, 6) + 1
                GoTo NextPart
            End If
            If InStr(mainARR(Rw, 1), "NW") > 0 Then
                minARR = Split(mainARR(Rw, 1), " To ")
                mLow = WorksheetFunction.Match(Trim(minARR(0)), Sheets("Lists").Range("Networks"), 0)
                mHigh = WorksheetFunction.Match(Trim(minARR(1)), Sheets("Lists").Range("Networks"), 0)
                If mLow > mHigh Then
                    If mainARR(Rw, 3) <> "" Then
                        mainARR(Rw, 3) = mainARR(Rw, 2) & " / " & "Upgrade"
                    Else
                        mainARR(Rw, 3) = "Upgrade"
                    End If
                Else
                    If mainARR(Rw, 3) <> "" Then
                        mainARR(Rw, 3) = mainARR(Rw, 2) & " / " & "Downgrade"
                    Else
                        mainARR(Rw, 3) = "Downgrade"
                    End If
                End If
                mainARR(Rw, 6) = mainARR(Rw, 6) + 1
            End If
        End If
NextPart:
        Cnt = 0
        If Len(mainARR(Rw, 2)) = 0 Then
            mainARR(Rw, 2) = "'-"
        ElseIf InStr(mainARR(Rw, 2), "/") = 0 Then
            mainARR(Rw, 5) = "Class " & mainARR(Rw, 2)
            Cnt = Cnt + 1
        Else
            minARR = Split(mainARR(Rw, 2), " / ")
            For s = LBound(minARR) To UBound(minARR)
                If Len(mainARR(Rw, 5)) > 0 Then
                    If Cnt = mainARR(Rw, 6) - 1 Then
                        mainARR(Rw, 5) = mainARR(Rw, 5) & " & Class " & minARR(s)
                    Else
                        mainARR(Rw, 5) = mainARR(Rw, 5) & ", Class " & minARR(s)
                    End If
                Else
                    mainARR(Rw, 5) = "Class " & minARR(s)
                End If
                Cnt = Cnt + 1
            Next s
        End If
        If Cnt = mainARR(Rw, 6) Then
            mainARR(Rw, 3) = "'-"
            mainARR(Rw, 4) = "'-"
            mainARR(Rw, 6) = ""
            GoTo NextRow
        End If
        
        If Len(mainARR(Rw, 3)) = 0 Then
            mainARR(Rw, 3) = "'-"
        ElseIf InStr(mainARR(Rw, 3), "/") = 0 Then
            If Len(mainARR(Rw, 5)) > 0 Then
                If Cnt = mainARR(Rw, 6) - 1 Then
                    mainARR(Rw, 5) = mainARR(Rw, 5) & " & Network " & mainARR(Rw, 3)
                Else
                    mainARR(Rw, 5) = mainARR(Rw, 5) & ", Network " & mainARR(Rw, 3)
                End If
            Else
                mainARR(Rw, 5) = "Network " & mainARR(Rw, 3)
            End If
            Cnt = Cnt + 1
        Else
            minARR = Split(mainARR(Rw, 3), " / ")
            For s = LBound(minARR) To UBound(minARR)
                If Len(mainARR(Rw, 5)) > 0 Then
                    If Cnt = mainARR(Rw, 6) - 1 Then
                        mainARR(Rw, 5) = mainARR(Rw, 5) & " & Network " & minARR(s)
                    Else
                        mainARR(Rw, 5) = mainARR(Rw, 5) & ", Network " & minARR(s)
                    End If
                Else
                    mainARR(Rw, 5) = "Network " & minARR(s)
                End If
                Cnt = Cnt + 1
            Next s
        End If
        If Cnt = mainARR(Rw, 6) Then
            mainARR(Rw, 4) = "'-"
            mainARR(Rw, 6) = ""
            GoTo NextRow
        End If
        If Len(mainARR(Rw, 4)) > 0 Then
            If Len(mainARR(Rw, 5)) > 0 Then
                mainARR(Rw, 5) = mainARR(Rw, 5) & " & Plan " & mainARR(Rw, 4)
            Else
                mainARR(Rw, 5) = "Plan " & mainARR(Rw, 4)
            End If
        Else
            mainARR(Rw, 4) = "'-"
        End If
        mainARR(Rw, 6) = ""
NextRow:
    Next Rw
WriteOut:
    .Range("C1:G" & LR).Value = mainARR
    .Range("C1:C" & LR).Value = BackupARR
    Exit Sub

ErrorHandling:
    If Rw > LR Then GoTo WriteOut
    mainARR(Rw, 2) = "XXXX"
    mainARR(Rw, 3) = "XXXX"
    mainARR(Rw, 4) = "XXXX"
    mainARR(Rw, 5) = "THIS ROW WON'T WORK"
    mainARR(Rw, 6) = ""
    GoTo NextRow

End With

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Solved
Categorizing and adding data with multiple conditions
Replies
5
Views
357
kevin9999
K
A
  • Question
Macro to Combine Data from Multiple Sheets
Replies
2
Views
169
ashringg
A
R
  • Question
Cell colour based on 10 different values
Replies
3
Views
312
Beneindias
B
J
  • Solved
Formula to Extract Address Based on Today's Date
Replies
5
Views
394
DanteAmor
DanteAmor
1
  • Question
Auto filter column on vlookup update on every sheets of the workbook
Replies
1
Views
170
10ml
1

Forum statistics

Threads
1,214,652
Messages
6,120,746
Members
448,989
Latest member
mariah3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top