Link to home
Start Free TrialLog in
Avatar of Israel Anthony Lopez
Israel Anthony LopezFlag for United States of America

asked on

Assigning a unique ID from a pool of unique IDs to a product.

I want to assign a unique number ID to a product based on the type of product it is.  

Product Type             Product Type Number                   Unique Identifier Range
General                              972                                               19216872100 through 19216872150  
Bakery                               1274                                              19210240100 through 19210240150
Produce                             12373                                            19211246100 through 19211246150
Meats                                 Due to the expense of meats they need to be tracked on a finite scale

Problem 1:  The record has already been tagged with the appropriate product type code by the store manager.  Each product type should be assigned a unique ID number from a list of unique ID numbers and no two of the same products can use the same unique ID number in a product type.  The list of unique ID numbers is different for each product type.  Of course, this has been scaled down due to the fact that there can be thousands of products in a grocery store.  

Problem 2:  This problem is similar in form and function to Problem 1 just re-used for a smaller scale.  Each meat type is coded for a particular meat type.  This is also coded from a fixed range of unique IDs identified by the store manager.  Again, no two types of packages of meat shall have the same unique ID and they must from the proper Sub Product Type.  This is important since this will track the meats.  Of course, this has been scaled down due to the fact that there can be thousands of packages of meat.  

Product Type           Sub Product Type             Unique Identifier Range
Meat                                 Deli 1 - Chicken                192128253-1  through 192128253-50
Meat                                 Deli 2 - Beef                      192128253-51  through 192128253-100
Meat                                 Deli 3 - Pork                      192128253-101  through 192128253-150
Meat                                 Deli 4 - Lamb                    192128253-151  through 192128253-200
Meat                                 Deli 5 - Fish                       192128253-201  through 192128253-250
Avatar of [ fanpages ]
[ fanpages ]

I want to assign a unique number ID to a product based on the type of product it is.

...and how can we help you?

PS. A Unique ID is surely unique across all Products; not just a Product Type.

The ranges for the Identifiers you have stated above confirms this.
Avatar of Israel Anthony Lopez

ASKER

Yes, but the Unique Identifier is assigned based on the Product Type Number.  Think of the Unique Identifier as a serial number that is always unique to this product type.  The only thing you need to do is to assign a Unique Identifier and ensure that a duplicate has not been issued.  



Dataset

Product Type           Product Type #           Unique Identifier

General                    972                                 19216872100
General                    972                                 19216872101
General                    972                                 19216872102
General                    972                                 19216872103
General                    972                                 19216872104
...                               ...                                     ...
General                    972                                 19216872150

In the real world example we have roughly 16 different Product Types and Product Type Numbers.  I just simplified it for this example.
OK... Potentially "Unique" then :)

...Still waiting for a question, or why you have created this thread, though.
I am sorry if I am not intelligent enough to say it any other way than "Assigning a unique ID from a pool of unique IDs to a product".  I want you to assign a unique number from a pool of numbers for right column in both examples.  I unable to explain it in any other way.  Sorry.
It is not a matter of intelligence; it's a matter of intent for assistance with a problem you are experiencing.

If that statement relates to what would you like the "Experts" to do for you, have you tried to do this task yourself & reached a point were you are not able to continue, or are you just expecting somebody to take over your project for you?

Either way, a sample workbook with the layout of your data & information regarding the presentation of the outcome within the workbook may help others engage with your thread.
No, I have tried for days to work on the problem.  I have done Excel spreadsheets that look for duplicate IPs in other sheets and returns a 0 for none, 1 for confirmation, 2 for duplicate, etc.  I also have done spreadsheets that go lookup whether a website is valid or not and returns a value.  Wait a minute...that might help.  While I look that up again, here is the spreadsheet that you requested.  

I have done many complex spreadsheets but I have never completed a VLOOKUP with a Match
My_CopyITS-Device-deployment-Planni.xlsx
ASKER CERTIFIED SOLUTION
Avatar of byundt
byundt
Flag of United States of America image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
I have nothing against VBA and have used VBA in other Excel spreadsheets.  

You are the Excel Master and all should worship at your feet.  :)   byundt, I appreciate this and this will help the common good since we deploy so much infrastructure in the field that provides traveler information to the public (CCTV cameras, vehicle detection to detect congestion, roadway signs to inform the public).  This helps people get where they want to get in a timely manner and you just made the very first step of getting that infrastructure available much easier.  

I am sure you read the "IP Assignment" question as well.  

https://www.experts-exchange.com/questions/28737521/Assign-an-IP-address-automatically-based-on-range-with-no-duplicate-assignments.html 

byundt, let me know if you need a recommendation or endorsement on LinkedIn.
The solution was stellar and exceeded my expectations.  Not only does the solution uniquely assign an IP address, all you have to do to assign an IP is click in the field.  Great work!
Israel Anthony Lopez,
Please continue to post in this thread if you have problems implementing the suggested approach in your real workbook.

The posted code made a number of assumptions in the effort to start a fruitful discussion. It is not robust enough to hand out to the masses. Among other things:
The code assumes that the list on the Master worksheet contains no gaps. All the IP addresses for a given type are in one continuous block, sorted by subtype.
There are no blank rows in the table on the Master worksheet. The code uses the MATCH and COUNTIFS function to determine where the next available IP is located, and blank rows will cause an incorrect answer to be given.
If all available IP addresses for a given type and subtype have been assigned, the code gives you one anyway. Error checking needs to be added.
I added a test for whether all available IPs (in a given type and subtype) have been used up. If so, NextIP returns a warning message.

I also added sub SortMasterIPs to sort the IPs on the Master worksheet by type, subtype, in use and IP. This eliminates the problem with blank rows and allows you to reuse an IP if you deallocate it (by manually clearing the X on the Master worksheet). This sub is called by a Worksheet_Deactivate sub on the Master worksheet, so it will run automatically whenever you switch away from the Master worksheet.

The combination of these tweaks addresses all three issues identified in my previous Comment.
'This sub must go in code pane of Master worksheet. It won't work at all if installed anywhere else!
Private Sub Worksheet_Deactivate()
SortMasterIPs
End Sub

Open in new window

'This code goes in a regular module sheet
Function NextIP(sType As String, sSubtype As String) As Variant
'Returns the next available IP address for a given type and subtype
Dim rgMaster As Range
Dim vType As Variant, vSubtype As Variant
Dim nAssigned As Long, nRows As Long, nAvailable As Long
Set rgMaster = Worksheets("Master").Range("A1").CurrentRegion
nRows = rgMaster.Rows.Count

vType = Application.Match(sType, rgMaster.Columns(1), 0)
If IsError(vType) Then
    NextIP = "No type match"
    Exit Function
End If

vSubtype = 0
If sSubtype <> "" Then
    vSubtype = Application.Match(sSubtype, Range(rgMaster.Cells(vType, 2), rgMaster.Cells(nRows, 2)), 0)
    If IsError(vSubtype) Then
        NextIP = "No subtype match"
        Exit Function
    Else
        vSubtype = vSubtype - 1
    End If
End If
nAvailable = Application.CountIfs(rgMaster.Columns(1), sType, rgMaster.Columns(2), sSubtype)
nAssigned = Application.CountIfs(rgMaster.Columns(1), sType, rgMaster.Columns(2), sSubtype, rgMaster.Columns(4), "<>")
NextIP = IIf(nAvailable > nAssigned, rgMaster.Cells(vType + vSubtype + nAssigned, 3).Value, "No IPs left")
End Function

Sub AssignIP(cel As Range)
Dim rg As Range, rgIP As Range, rgMaster As Range
Dim sType As String, sSubtype As String
Dim vIP As Variant, vType As Variant, vSubtype As Variant
Dim i As Long, nIP As Long
Set rg = cel.Offset(0, -1).CurrentRegion
Set rgMaster = Worksheets("Master").Range("A1").CurrentRegion
vType = Application.Match("Product Type", rg.Rows(1), 0)
If IsError(vType) Then
    MsgBox "Could not find Product Type column"
    Exit Sub
Else
    vSubtype = Application.Match("Sub Product Type", rg.Rows(1), 0)
    i = cel.Row - rgMaster.Row + 1
    sType = rg.Cells(i, vType).Value
    If Not IsError(vSubtype) Then sSubtype = rg.Cells(i, vSubtype).Value
    vIP = NextIP(sType, sSubtype)
    cel.Value = vIP
    If IsNumeric(Left(vIP, 3)) Then
        nIP = Application.Match(vIP, rgMaster.Columns(3), 0)
        rgMaster.Cells(nIP, 4).Value = "X"
    End If
End If
End Sub

Sub SortMasterIPs(Optional b As Boolean)
'Sorts the master IP list by type, subtype, in use and IP
Dim rg As Range
Application.ScreenUpdating = False
With Worksheets("Master")
    Set rg = .Range("A1").CurrentRegion
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rg.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rg.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rg.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rg.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Open in new window

ITS-Device-deployment-PlanningQ2874.xlsm
There is one thing I did notice, which is not so much an issue, that once the "X" is placed it does not update the "Master" sheet if an IP address in the "IP Address" column on the "IPs" sheet is deleted.  I put instructions that the user must also remove the X on the Master sheet.
For not being much of an issue, it took a surprising amount of code to automate. I had to take into consideration whether a change was made to a non-IP cell, more than one IP cells were cleared, and whether the user tried to clear compound ranges.

The following two subs go in the IPs worksheet code pane. The Worksheet_Change sub is triggered whenever a cell on that worksheet has its value changed by the user or a macro. To avoid calling that sub needlessly, I modified Worksheet_BeforeDoubleClick so it would avoid triggering Worksheet_Change.

Worksheet_Change first checks whether a compound range was changed. If so, it reverses the action and displays a warning message. Next, it checks whether the changed cells are in a Unique Identifier column, are now blank and formerly contained an IP address. If so, it reverses the change, clears the X on the corresponding row of the Master worksheet, then restores the values on the IPs worksheet.
'This code must go in the code pane of the worksheet being watched. It won't work at all if installed anywhere else.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.EntireColumn.Cells(1, 1).Value = "Unique Identifier" Then
    If Target.Cells(1, 1).Value = "" Then
        Application.EnableEvents = False
        AssignIP Target.Cells(1, 1)
        Application.EnableEvents = True
        Cancel = True
    End If
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, celHome As Range
Dim vID As Variant, vTarget As Variant
Dim bID As Boolean
Dim i As Long, j As Long, nCols As Long, nRows As Long
Const IPheader As String = "Unique Identifier"
Application.EnableEvents = False
If Target.Areas.Count > 1 Then
    Application.Undo
    MsgBox "It is not permitted to make changes on compound ranges in this worksheet"
Else
    Application.ScreenUpdating = False
    Set celHome = ActiveCell
    For Each cel In Target.Cells
        If (cel.EntireColumn.Cells(1, 1).Value = IPheader) And (cel.Value = "") Then
            bID = True
            Exit For
        End If
    Next
    
    If bID = True Then
        vTarget = Target.Value
        nCols = Target.Columns.Count
        nRows = Target.Rows.Count
        Application.Undo
        For i = 1 To nRows
            For j = 1 To nCols
                If Target.Cells.Count = 1 Then
                    If IsNumeric(Left(Target.Value, 3)) Then ClearTheX (Target.Value)
                Else
                    If Target.Cells(i, j).EntireColumn.Cells(1, 1).Value = IPheader Then
                        If IsNumeric(Left(Target.Cells(i, j).Value, 3)) And vTarget(i, j) = "" Then ClearTheX (Target.Cells(i, j).Value)
                    End If
                End If
            Next
        Next
        Target.Value = vTarget
    End If
    Application.Goto celHome
End If
Application.EnableEvents = True
End Sub

Open in new window

The event sub calls sub ClearTheX, which should be placed in a regular module sheet. This sub looks for the IP address on worksheet Master, then clears the X to its right.
Sub ClearTheX(vIP As Variant)
Dim rgMaster As Range
Dim nIP As Variant
Set rgMaster = Worksheets("Master").Range("A1").CurrentRegion
nIP = Application.Match(vIP, rgMaster.Columns(3), 0)
If IsNumeric(nIP) Then rgMaster.Cells(CLng(nIP), 4).ClearContents
End Sub

Open in new window

ITS-Device-deployment-PlanningQ2874.xlsm
I thought it might be dangerous to permit a person to clear a unique identifier and make it available for reuse, so I added a MsgBox with an "are you sure?" type warning message. If affirmative, then the identifier cell is cleared and the X removed from worksheet Master. I also thought it might be intuitive to doubleclick a unique identifier to clear it, once again after responding affirmatively to a warning message. So the user now has two ways to clear the unique identifiers, both of them safeguarded by a warning message.
'This code must go in the code pane of the worksheet being watched. It won't work at all if installed anywhere else.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.EntireColumn.Cells(1, 1).Value = "Unique Identifier" Then
    If Target.Value = "" Then
        Application.EnableEvents = False
        AssignIP Target
        Application.EnableEvents = True
    ElseIf IsNumeric(Left(Target.Value, 3)) Then
        If MsgBox("Is identifier for device no longer in use and available for reassignment?", vbYesNoCancel) = vbYes Then
            ClearTheX (Target.Value)
            Application.EnableEvents = False
            Target.ClearContents
            Application.EnableEvents = True
        End If
    End If
    Cancel = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, celHome As Range
Dim vID As Variant, vOldTarget As Variant, vTarget As Variant
Dim bID As Boolean, bLoopDone As Boolean
Dim i As Long, j As Long, nCols As Long, nRows As Long, TargCol As Long
Const IPheader As String = "Unique Identifier"
If Target.Areas.Count > 1 Then
    Application.EnableEvents = False
    Application.Undo
    MsgBox "It is not permitted to make changes on compound ranges in this worksheet"
    Application.EnableEvents = True
Else
    TargCol = Target.Column
    vTarget = Target.Value
    nCols = Target.Columns.Count
    nRows = Target.Rows.Count
    
    If nRows * nCols = 1 Then
        If (Cells(1, TargCol).Value = IPheader) And (vTarget = "") Then
            If MsgBox("Is identifier for device no longer in use and available for reassignment?", vbYesNoCancel) = vbYes Then
                bID = True
            Else
                Application.EnableEvents = False
                Application.Undo
                Application.EnableEvents = True
            End If
        End If
    Else
        For i = 1 To nRows
            For j = 1 To nCols
                If (Cells(1, TargCol + j - 1).Value = IPheader) And (vTarget(i, j) = "") Then
                    If MsgBox("Are identifiers for devices no longer in use and available for reassignment?", vbYesNoCancel) = vbYes Then
                        bID = True
                    Else
                        Application.EnableEvents = False
                        Application.Undo
                        Application.EnableEvents = True
                    End If
                    bLoopDone = True
                    Exit For
                End If
            Next
            If bLoopDone = True Then Exit For
        Next
    End If
    
    If bID = True Then
        Set celHome = ActiveCell
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Undo
        vOldTarget = Target.Value
        Target.Value = vTarget
        Application.EnableEvents = True
        
        nCols = Target.Columns.Count
        nRows = Target.Rows.Count
        For i = 1 To nRows
            For j = 1 To nCols
                If nRows * nCols = 1 Then
                    If IsNumeric(Left(vOldTarget, 3)) Then ClearTheX (vOldTarget)
                Else
                    If Cells(1, TargCol + j - 1).Value = IPheader Then
                        If IsNumeric(Left(vOldTarget(i, j), 3)) And vTarget(i, j) = "" Then ClearTheX (vOldTarget(i, j))
                    End If
                End If
            Next
        Next
        Application.Goto celHome
    End If
End If
End Sub

Open in new window

ITS-Device-deployment-PlanningQ2874.xlsm
Awesome!  Thanks...
The actual workbook (which I saw in a Private Message) did not have a Subtype column on worksheet IPs. I revised the code to tolerate its absence and to display the nag message only when necessary (trying to clear one or more cells with an IP address). The revised code appears below.
'This code must go in the code pane of the worksheet being watched. It won't work at all if installed anywhere else.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.EntireColumn.Cells(1, 1).Value = "IP Address" Then
    If Target.Value = "" Then
        Application.EnableEvents = False
        AssignIP Target
        Application.EnableEvents = True
    ElseIf IsNumeric(Left(Target.Value, 3)) Then
        If MsgBox("Is identifier for device no longer in use and available for reassignment?", vbYesNoCancel) = vbYes Then
            ClearTheX (Target.Value)
            Application.EnableEvents = False
            Target.ClearContents
            Application.EnableEvents = True
        End If
    Else
        Application.EnableEvents = False
        Target.ClearContents
        Application.EnableEvents = True
    End If
    Cancel = True
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cel As Range, celHome As Range
Dim vID As Variant, vOldTarget As Variant, vTarget As Variant
Dim bID As Boolean, bLoopDone As Boolean
Dim i As Long, j As Long, nCols As Long, nRows As Long, TargCol As Long

Set celHome = ActiveCell
Application.EnableEvents = False
If Target.Areas.Count > 1 Then
    Application.Undo
    MsgBox "It is not permitted to make changes on compound ranges in this worksheet"
Else
    TargCol = Target.Column
    vTarget = Target.Value
    nCols = Target.Columns.Count
    nRows = Target.Rows.Count
    Application.Undo
    vOldTarget = Target.Value
    
    If nRows * nCols = 1 Then
        If (Cells(1, TargCol).Value = IPheader) And (vTarget = "") And (IsNumeric(Left(vOldTarget, 3))) Then
            bID = (MsgBox("Is identifier for device no longer in use and available for reassignment?", vbYesNoCancel) = vbYes)
        End If
    Else
        For i = 1 To nRows
            For j = 1 To nCols
                If (Cells(1, TargCol + j - 1).Value = IPheader) And (vTarget(i, j) = "") And (IsNumeric(Left(vOldTarget(i, j), 3))) Then
                    bID = (MsgBox("Are identifiers for devices no longer in use and available for reassignment?", vbYesNoCancel) = vbYes)
                    bLoopDone = True
                    Exit For
                End If
            Next
            If bLoopDone = True Then Exit For
        Next
    End If
    
    If bID = True Then
        Application.ScreenUpdating = False
        
        nCols = Target.Columns.Count
        nRows = Target.Rows.Count
        For i = 1 To nRows
            For j = 1 To nCols
                If nRows * nCols = 1 Then
                    ClearTheX (vOldTarget)
                    Target.Value = vTarget
                Else
                    If Cells(1, TargCol + j - 1).Value = IPheader Then
                        If IsNumeric(Left(vOldTarget(i, j), 3)) And vTarget(i, j) = "" Then ClearTheX (vOldTarget(i, j))
                    End If
                    Target.Cells(i, j).Value = vTarget(i, j)
                End If
            Next
        Next
    
    Else
        Target.Value = vTarget
    End If
    Application.Goto celHome
End If
Application.EnableEvents = True
End Sub

Open in new window

'The public constants must match the header labels used in worksheet IPs
Public Const IPheader As String = "IP Address"
Public Const TypeHeader As String = "VLAN Device Type"
Public Const SubtypeHeader As String = ""                   'Equals "" because not used
'Code assumes a four column list on worksheet Master containing Type, Subtype, IP Address and In Use. _
    Type and IP Address are required, but Subtype is optional. _
    In Use will be marked with an X when that row's IP Address is assigned.

'This code goes in a regular module sheet
Function NextIP(sType As String, sSubtype As String) As Variant
'Returns the next available IP address for a given type and subtype
Dim rgMaster As Range
Dim vType As Variant, vSubtype As Variant
Dim nAssigned As Long, nRows As Long, nAvailable As Long
Set rgMaster = Worksheets("Master").Range("A1").CurrentRegion
nRows = rgMaster.Rows.Count

vType = Application.Match(sType, rgMaster.Columns(1), 0)
If IsError(vType) Then
    NextIP = "No type match"
    Exit Function
End If

vSubtype = 0
If sSubtype <> "" Then
    vSubtype = Application.Match(sSubtype, Range(rgMaster.Cells(vType, 2), rgMaster.Cells(nRows, 2)), 0)
    If IsError(vSubtype) Then
        NextIP = "No subtype match"
        Exit Function
    Else
        vSubtype = vSubtype - 1
    End If
End If
nAvailable = Application.CountIfs(rgMaster.Columns(1), sType, rgMaster.Columns(2), sSubtype)
nAssigned = Application.CountIfs(rgMaster.Columns(1), sType, rgMaster.Columns(2), sSubtype, rgMaster.Columns(4), "<>")
NextIP = IIf(nAvailable > nAssigned, rgMaster.Cells(vType + vSubtype + nAssigned, 3).Value, "No IPs left")
End Function

Sub AssignIP(cel As Range)
Dim rg As Range, rgIP As Range, rgMaster As Range
Dim sType As String, sSubtype As String
Dim vIP As Variant, vType As Variant, vSubtype As Variant
Dim i As Long, nIP As Long
Set rg = cel.Offset(0, -1).CurrentRegion
Set rgMaster = Worksheets("Master").Range("A1").CurrentRegion
vType = Application.Match(TypeHeader, rg.Rows(1), 0)
If IsError(vType) Then
    MsgBox "Could not find Product Type column"
    Exit Sub
Else
    On Error Resume Next
    vSubtype = Application.Match(SubtypeHeader, rg.Rows(1), 0)
    On Error GoTo 0
    i = cel.Row - rgMaster.Row + 1
    sType = rg.Cells(i, vType).Value
    If Not IsError(vSubtype) Then sSubtype = rg.Cells(i, vSubtype).Value
    vIP = NextIP(sType, sSubtype)
    cel.Value = vIP
    If IsNumeric(Left(vIP, 3)) Then
        nIP = Application.Match(vIP, rgMaster.Columns(3), 0)
        rgMaster.Cells(nIP, 4).Value = "X"
    End If
End If
End Sub

Sub ClearTheX(vIP As Variant)
Dim rgMaster As Range
Dim nIP As Variant
Set rgMaster = Worksheets("Master").Range("A1").CurrentRegion
nIP = Application.Match(vIP, rgMaster.Columns(3), 0)
If IsNumeric(nIP) Then rgMaster.Cells(CLng(nIP), 4).ClearContents
End Sub

Sub SortMasterIPs(Optional b As Boolean)
'Sorts the master IP list by type, subtype, in use and IP
Dim rg As Range
Application.ScreenUpdating = False
With Worksheets("Master")
    Set rg = .Range("A1").CurrentRegion
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=rg.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rg.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rg.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .Sort.SortFields.Add Key:=rg.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange rg
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End With
End Sub

Open in new window

This works great