none
Fill a column according to a criteria but the value must change if it has already been used RRS feed

  • Question

  • Hello,

    As you can see in the copy of my worksheet below, I am trying to build a macro which would fill the SubType colum automatically.

    The condition for a SubType to be assigned is if a Type is anything else than "Primary". All the other possible values are listed in another tab called "helpers".

    But, as you can see, if two rows have the same OwnerID and Type value, they can't have the same SubType value. 

    The naming convention that we use for these SubType is that if it hasn't been assigned yet then it is simply =Application&"_Additional_"&Type as you would see in a formula. If it has been assigned already, as you can see in the last row, then it should be =Application&"_Additional_"&Accountname.

    Accountname OwnerID Type Active Application Environment IsPriviledged SubType
    GRA B24893 Primary TRUE ReutersDealing PROD FALSE
    MW B316 Personal TRUE ReutersDealing PROD FALSE ReutersDealing_Additional_personal
    PP B2211 Primary TRUE ReutersDealing PROD FALSE
    RIE B18481 Primary TRUE ReutersDealing PROD FALSE
    WOH B316 Primary TRUE ReutersDealing PROD FALSE
    SPA B1775 Primary TRUE ReutersDealing PROD TRUE
    BOE B34975 Primary TRUE ReutersDealing PROD TRUE
    WAL B76166 Primary TRUE ReutersDealing PROD TRUE
    MW B316 Personal TRUE ReutersDealing PROD FALSE ReutersDealing_Additional_MW


    I tried to do it with a formula but I couldn't get it to work and thought that only a macro could do the trick. But the macro I wrote doesn't want to work for some reason.

    Sub SubType()
    
        Dim ACCOUNTS As Worksheet
        Dim helpers As Worksheet
        Dim Role_Importer As Worksheet
        Dim m As Long
        Dim t As Long
        Dim Accountname
        Dim ApplicationName As String
        Dim AccountType As String
        Dim AccountTypeWithoutCap As String
        Dim ACCOUNTSCell As Range
        Dim SubType As String
        Dim helpersCell As Range
        Dim helpersAddress As String
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set helpers = Worksheets("helpers")
        Set ACCOUNTS = Worksheets("ACCOUNTS")
        Set Role_Importer = Worksheets("Role_Importer")
        ApplicationName = Role_Importer.Range("D2").Value
        t = 1
        m = ACCOUNTS.Range("C" & ACCOUNTS.Rows.Count).End(xlUp).Row
        For Each ACCOUNTSCell In ACCOUNTS.Range("C2:C" & m)
            Accountname = ACCOUNTSCell.Value
            AccountType = ACCOUNTSCell.Offset(0, 4).Value
            If AccountType = "Primary" Then
            SubType = ""
            Else:
            Set helpersCell = helpers.Range("A:A").Find(What:=AccounType, LookAt:=xlWhole)
            If Not helpersCell Is Nothing Then
                helpersAddress = helpersCell.Address
                Do
                    AccountTypeWithoutCap = helpersCell.Offset(0, 5).Value
                            t = t + 1
                            ACCOUNTS.Range("N" & t).Value = ApplicationName
                Loop Until helpersCell.Address = helpersAddress
            End If
            End If
        Next ACCOUNTSCell
        ACCOUNTS.Range("N1").EntireColumn.AutoFit
        Application.EnableEvents = True
        Application.ScreenUpdating = True
              
        End With
    End Sub

    This "helpers" tab contains the Type values with and without first capital letter, to help writing the SubType value.

    For the line I quoted below, I only wrote = ApplicationName to test before writing the whole thing and to be honest I'm not quite sure how to write this the same way as a formula, i.e. by designating specific cells.

    ACCOUNTS.Range("N" & t).Value = ApplicationName

    Also I didn't write the part about the no SubType duplicate as I explained above. I couldn't find a way to do that.

    Can anyone please help me to finish this macro? Let me know if there's anything unclear.

    Best,

    Monday, January 13, 2020 9:55 AM

Answers

  • Try this:

    Sub FillSubType()
        Dim ACCOUNTS As Worksheet
        Dim Role_Importer As Worksheet
        Dim r As Long
        Dim m As Long
        Dim t As Long
        Dim Accountname
        Dim ApplicationName As String
        Dim AccountType As String
        Dim SubType As String
        Dim dict As Object
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set dict = CreateObject("Scripting.Dictionary")
        Set ACCOUNTS = Worksheets("ACCOUNTS")
        Set Role_Importer = Worksheets("Role_Importer")
        ApplicationName = Role_Importer.Range("D2").Value
        t = 1
        m = ACCOUNTS.Range("C" & ACCOUNTS.Rows.Count).End(xlUp).Row
        For r = 2 To m
            Accountname = ACCOUNTS.Range("C" & r).Value
            AccountType = ACCOUNTS.Range("E" & r).Value
            If AccountType = "Primary" Then
                SubType = ""
            Else
                If dict.exists(Accountname) Then
                    SubType = ApplicationName & "_Additional_" & Accountname
                Else
                    dict(Accountname) = 1
                    SubType = ApplicationName & "_Additional_" & AccountType
                End If
            End If
            ACCOUNTS.Range("N" & r).Value = SubType
        Next r
        ACCOUNTS.Range("N1").EntireColumn.AutoFit
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by charliecoch1 Monday, January 13, 2020 2:41 PM
    Monday, January 13, 2020 1:09 PM

All replies

  • Try this:

    Sub FillSubType()
        Dim ACCOUNTS As Worksheet
        Dim Role_Importer As Worksheet
        Dim r As Long
        Dim m As Long
        Dim t As Long
        Dim Accountname
        Dim ApplicationName As String
        Dim AccountType As String
        Dim SubType As String
        Dim dict As Object
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set dict = CreateObject("Scripting.Dictionary")
        Set ACCOUNTS = Worksheets("ACCOUNTS")
        Set Role_Importer = Worksheets("Role_Importer")
        ApplicationName = Role_Importer.Range("D2").Value
        t = 1
        m = ACCOUNTS.Range("C" & ACCOUNTS.Rows.Count).End(xlUp).Row
        For r = 2 To m
            Accountname = ACCOUNTS.Range("C" & r).Value
            AccountType = ACCOUNTS.Range("E" & r).Value
            If AccountType = "Primary" Then
                SubType = ""
            Else
                If dict.exists(Accountname) Then
                    SubType = ApplicationName & "_Additional_" & Accountname
                Else
                    dict(Accountname) = 1
                    SubType = ApplicationName & "_Additional_" & AccountType
                End If
            End If
            ACCOUNTS.Range("N" & r).Value = SubType
        Next r
        ACCOUNTS.Range("N1").EntireColumn.AutoFit
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    • Marked as answer by charliecoch1 Monday, January 13, 2020 2:41 PM
    Monday, January 13, 2020 1:09 PM
  • Wow okay for some reason, it's working perfectly. Thanks for all the help you've given me these past few days Hans. Although there are still a lot of things I don't understand, I could learn a lot about VBA by looking at the macros you created for me.

    Would you have a recommendation for an online course to really learn VBA effectively?

    Best,

    Charles Cochener

    Monday, January 13, 2020 2:41 PM
  • Actually, I spoke too quickly.

    Let's have a look below:

    Accountname OwnerID Type Application SubType
    GRA B24893 Primary ReutersDealing
    MW B316 Personal ReutersDealing ReutersDealing_Additional_Personal
    PP B2211 Primary ReutersDealing
    RIE B18481 Primary ReutersDealing
    WOH B316 Primary ReutersDealing
    SPA B1775 Emergency ReutersDealing ReutersDealing_Additional_Emergency
    BOE B34975 Primary ReutersDealing
    WAL B76166 Primary ReutersDealing
    BLABLA B1775 Emergency ReutersDealing ReutersDealing_Additional_Emergency

    As you can see, I tried the macro by changing the Type of two accounts with the same OwnerID to "Emergency", but it results in the same SubType. This can't be because an OwnerID can't have the same SubType. In the example above, the expected result for the account BLABLA would be ReutersDealing_Additional_BLABLA.

    Is that possible?

    Best,


    Monday, January 13, 2020 2:51 PM
  • Try this version:

    Sub FillSubType()
        Dim ACCOUNTS As Worksheet
        Dim Role_Importer As Worksheet
        Dim r As Long
        Dim m As Long
        Dim t As Long
        Dim Accountname
        Dim OwnerID As String
        Dim ApplicationName As String
        Dim AccountType As String
        Dim SubType As String
        Dim dict As Object
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set dict = CreateObject("Scripting.Dictionary")
        Set ACCOUNTS = Worksheets("ACCOUNTS")
        Set Role_Importer = Worksheets("Role_Importer")
        ApplicationName = Role_Importer.Range("D2").Value
        t = 1
        m = ACCOUNTS.Range("C" & ACCOUNTS.Rows.Count).End(xlUp).Row
        For r = 2 To m
            Accountname = ACCOUNTS.Range("C" & r).Value
            OwnerID = ACCOUNTS.Range("D" & r).Value
            AccountType = ACCOUNTS.Range("E" & r).Value
            If AccountType = "Primary" Then
                SubType = ""
            Else
                If dict.exists(OwnerID) Then
                    SubType = ApplicationName & "_Additional_" & Accountname
                Else
                    dict(OwnerID) = 1
                    SubType = ApplicationName & "_Additional_" & AccountType
                End If
            End If
            ACCOUNTS.Range("N" & r).Value = SubType
        Next r
        ACCOUNTS.Range("N1").EntireColumn.AutoFit
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Monday, January 13, 2020 8:16 PM
  • :/ sorry it is the same problem here.

    Accountname OwnerID Type Application SubType
    GRA B24893 Primary ReutersDealing
    MW B316 Personal ReutersDealing ReutersDealing_Additional_Personal
    PP B2211 Primary ReutersDealing
    RIE B18481 Primary ReutersDealing
    WOH B316 Primary ReutersDealing
    SPA B1775 Primary ReutersDealing
    BOE B34975 Primary ReutersDealing
    WAL B76166 Primary ReutersDealing
    blabla B316 Built-In ReutersDealing ReutersDealing_Additional_blabla
    test B316 Personal ReutersDealing ReutersDealing_Additional_test

    As you can see, I created two dummy accounts at the end.

    The "test" account is perfect, the user B316 already has a Personal Type  and therefore the SubType is correct for this row.

    However, the "blabla" account, even if attributed to B316, has a Built-In Type for the first time, thus it should be ReutersDealing_Additional_Built-In.

    Any idea how to fix this?

    Tuesday, January 14, 2020 2:46 PM
  • Before I work on it: please describe ALL possible situations in detail, else this will go on endlessly, with a new exception each time.

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, January 14, 2020 3:10 PM
  • Ok sorry, these are all the possible values:

    Primary
    Production
    Emergency
    Shared
    Technical
    Personal
    Built-In
    Unspecified

    Apologize for the inconvenience, I thought you did it a way it would recognize any Type value.

    Initially I tried to do this macro by having this list stored in this "helpers" tab in the range A2:A9. Maybe this would be easier for you? Let me know :) 

    Tuesday, January 14, 2020 3:35 PM
  • See if this does what you want:

    Sub FillSubType()
        Dim ACCOUNTS As Worksheet
        Dim Role_Importer As Worksheet
        Dim r As Long
        Dim m As Long
        Dim t As Long
        Dim Accountname
        Dim OwnerID As String
        Dim ApplicationName As String
        Dim AccountType As String
        Dim SubType As String
        Dim dict As Object
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Set dict = CreateObject("Scripting.Dictionary")
        Set ACCOUNTS = Worksheets("ACCOUNTS")
        Set Role_Importer = Worksheets("Role_Importer")
        ApplicationName = Role_Importer.Range("D2").Value
        t = 1
        m = ACCOUNTS.Range("C" & ACCOUNTS.Rows.Count).End(xlUp).Row
        For r = 2 To m
            Accountname = ACCOUNTS.Range("C" & r).Value
            OwnerID = ACCOUNTS.Range("D" & r).Value
            AccountType = ACCOUNTS.Range("E" & r).Value
            If AccountType = "Primary" Then
                SubType = ""
            Else
                If dict.exists(OwnerID & AccountType) Then
                    SubType = ApplicationName & "_Additional_" & Accountname
                Else
                    dict(OwnerID & AccountType) = 1
                    SubType = ApplicationName & "_Additional_" & AccountType
                End If
            End If
            ACCOUNTS.Range("N" & r).Value = SubType
        Next r
        ACCOUNTS.Range("N1").EntireColumn.AutoFit
        Application.EnableEvents = True
        Application.ScreenUpdating = True
    End Sub


    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Tuesday, January 14, 2020 8:14 PM
  • That's great. Looks like it's working out exactly the way I wanted it to now.

    I didn't know about this "dictionary" feature before. Handy. Thank you so much for your help. 

    Forgive me for asking again, but do you have a recommendation for learning VBA?

    Wednesday, January 15, 2020 8:37 AM
  • See for example https://www.excel-easy.com/vba.html

    Regards, Hans Vogelaar (http://www.eileenslounge.com)

    Wednesday, January 15, 2020 12:12 PM
  • Will look into it. Thanks again :)
    Wednesday, January 15, 2020 1:32 PM