Search code examples
excelvba

VBA excel script to generate unique code based on certain conditions

I have created a vba script to generate unique box code based on certain conditions.It is required to pack 2 subjects having same book numbers.

  1. Both subjects are in same distribution center & in same school
  2. One box can accommodate 300 books so within same distribution center, multiple schools can be packed as long as both the subjects are there and should not be more than 300 books altogether.
  3. If the books quantity of both subjects is more than 300, create another code in next column for another box. Both subjects must be having same school and same number quantity.

I created 2 separate codes first to pack books within same distribution center with 2 subjects with quantity 300 or less. and exclude schools with more than 100 books. then add columns to generate codes for excluded books based on total quantity.

I am facing difficulty in cases where if the total number of books reaches 300 or less, it exclude the subject and put it in another box. I need to keep both subjects together at all times. Please help modify the code. Thanks fr the support. Below is the code

Sub GenerateUniqueCode_Stage1()
Dim ws As Worksheet
Dim lastRow As Long
Dim distCenterCol As Range, schoolCol As Range, quantityCol As Range, subjectCol As Range, codeCol As Range
Dim boxCounter As Long
Dim prevDistCenter As String
Dim boxCode As String
Dim totalBooks As Long
Dim boxSubjects As String
Dim i As Long

' Set the worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")

' Find the last row with data in column E
lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row

' Set the ranges for the columns
Set distCenterCol = ws.Range("E2:E" & lastRow)
Set schoolCol = ws.Range("G2:G" & lastRow)
Set quantityCol = ws.Range("H2:H" & lastRow)
Set subjectCol = ws.Range("I2:I" & lastRow)
Set codeCol = ws.Range("K2:K" & lastRow)

' Initialize variables
boxCounter = 1
prevDistCenter = distCenterCol.Cells(2).Value
boxCode = "BOX-" & Format(boxCounter, "000")
totalBooks = 0
boxSubjects = ""

' Loop through each row in the data
For i = 2 To lastRow
    distCenter = distCenterCol.Cells(i).Value
    school = schoolCol.Cells(i).Value
    subject = subjectCol.Cells(i).Value
    remainingBooks = quantityCol.Cells(i).Value

    ' Exclude schools with quantity 100 or more
    If remainingBooks >= 100 Then
        codeCol.Cells(i).Value = "Excluded"
    Else
        ' Check if distribution center changes or adding the books exceeds the box limit
        If distCenter <> prevDistCenter Or totalBooks + remainingBooks > 300 Or (InStr(1, boxSubjects, "English") = 0 And InStr(1, boxSubjects, "Social & Religious Studies") = 0) Then
            ' Start a new box
            boxCounter = boxCounter + 1
            boxCode = Left(distCenter, 3) & "BOXENGSOC" & Format(boxCounter, "000")
            totalBooks = remainingBooks
            boxSubjects = subject
        Else
            totalBooks = totalBooks + remainingBooks
            boxSubjects = boxSubjects & ", " & subject
        End If

        ' Update the box code in column K
        codeCol.Cells(i).Value = boxCode

        ' Update the previous distribution center
        prevDistCenter = distCenter
    End If
Next i
End Sub

Second code

Sub GenerateAdditionalUBCCode_Stage2_rev1()

Dim lastRow As Long
Dim ws As Worksheet
Dim boxCounter As Integer
Dim ubcCode As String
Dim envCount As Long
Dim totalEnvCount As Long
Dim distCenter As String
Dim columnOffset As Integer
Dim currentColumn As Integer

Set ws = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to your actual sheet name

lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row

' Find the last used UBC code and update the boxCounter accordingly
Dim lastUBCRow As Long
lastUBCRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row
If lastUBCRow > 1 Then
    boxCounter = Val(Right(ws.Cells(lastUBCRow, "K").Value, 4)) + 1
Else
    boxCounter = 1
End If

For columnOffset = 0 To 11 ' 12 columns from L to W
    currentColumn = 12 + columnOffset ' Column L is 12, M is 13, and so on
    
    For i = 2 To lastRow
        If ws.Cells(i, "S").Value = 0 Then
            ' Skip rows where ENV Count is 0
            GoTo SkipIteration
        End If
        
        If ws.Cells(i, "I").Value = "English" And ws.Cells(i, "K").Value = ws.Cells(i + 1, "K").Value And ws.Cells(i, "S").Value = ws.Cells(i + 1, "S").Value Then
            totalEnvCount = ws.Cells(i, "S").Value + ws.Cells(i + 1, "S").Value
            distCenter = Left(ws.Cells(i, "E").Value, 3) ' Get the first 3 characters of the Distribution Center
            
            If totalEnvCount <= 6 And columnOffset = 0 Then
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, currentColumn).Value = ubcCode ' Update the cell in the current column
                ws.Cells(i + 1, currentColumn).Value = ubcCode ' Update the next cell in the current column
                boxCounter = boxCounter + 1
                i = i + 1
            ElseIf totalEnvCount > 6 And totalEnvCount <= 12 And columnOffset <= 1 Then
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, currentColumn + 1).Value = ubcCode ' Update the next cell in the next column
                ws.Cells(i + 1, currentColumn + 1).Value = ubcCode ' Update the next cell in the next column
                boxCounter = boxCounter + 1
                i = i + 1
            ElseIf totalEnvCount > 12 And totalEnvCount <= 18 And columnOffset <= 2 Then
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, currentColumn + 2).Value = ubcCode ' Update the next cell in the next column
                ws.Cells(i + 1, currentColumn + 2).Value = ubcCode ' Update the next cell in the next column
                boxCounter = boxCounter + 1
                i = i + 1
            ElseIf totalEnvCount > 18 And totalEnvCount <= 24 And columnOffset <= 3 Then
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, currentColumn + 3).Value = ubcCode ' Update the next cell in the next column
                ws.Cells(i + 1, currentColumn + 3).Value = ubcCode ' Update the next cell in the next column
                boxCounter = boxCounter + 1
                i = i + 1
            ElseIf totalEnvCount > 24 And totalEnvCount <= 30 And columnOffset <= 4 Then
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, currentColumn + 4).Value = ubcCode ' Update the next cell in the next column
                ws.Cells(i + 1, currentColumn + 4).Value = ubcCode ' Update the next cell in the next column
                boxCounter = boxCounter + 1
                i = i + 1
            ElseIf totalEnvCount > 30 And totalEnvCount <= 36 And columnOffset <= 5 Then
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, currentColumn + 5).Value = ubcCode ' Update the next cell in the next column
                ws.Cells(i + 1, currentColumn + 5).Value = ubcCode ' Update the next cell in the next column
                boxCounter = boxCounter + 1
                i = i + 1
            ElseIf totalEnvCount > 36 And totalEnvCount <= 42 And columnOffset <= 6 Then
                ubcCode = distCenter & "BOXXENGSOC" & Format(boxCounter, "000")
                ws.Cells(i, currentColumn + 6).Value = ubcCode ' Update the next cell in the next column
                ws.Cells(i + 1, currentColumn + 6).Value = ubcCode ' Update the next cell in the next column
                boxCounter = boxCounter + 1
                i = i + 1
            End If
        End If
        
SkipIteration:
    Next i
Next columnOffset
 
'Remove EXCLUDED from colum K

' Find the last row with data in column K
lastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row

' Loop through each cell in column K from row 1 to the last row
For Each cell In ws.Range("K2:K" & lastRow)
    ' Check if the cell value is "Excluded" and then clear the cell
    If cell.Value = "Excluded" Then
        cell.ClearContents
    End If
Next cell
End Sub

Sample of error Please help.

Solution

    • Please add some lines of code to revise the logic for validating the maximum capacity of each box. All books for the same school should be counted.

    • As Col range stars from row 2, the start value of For loop should be 1. that is For i = 1 To lastRow.

    ' Set the ranges for the columns
Set distCenterCol = ws.Range("E2:E" & lastRow)

For i = 2 To lastRow
    distCenter = distCenterCol.Cells(i).Value


    Option Explicit
Sub GenerateUniqueCode_Stage1()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim distCenterCol As Range, schoolCol As Range, quantityCol As Range, subjectCol As Range, codeCol As Range
    Dim boxCounter As Long
    Dim prevDistCenter As String
    Dim boxCode As String
    Dim totalBooks As Long
    Dim boxSubjects As String
    Dim i As Long
    ' Set the worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' Find the last row with data in column E
    lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
    ' Set the ranges for the columns
    Set distCenterCol = ws.Range("E2:E" & lastRow)
    Set schoolCol = ws.Range("G2:G" & lastRow)
    Set quantityCol = ws.Range("H2:H" & lastRow)
    Set subjectCol = ws.Range("I2:I" & lastRow)
    Set codeCol = ws.Range("K2:K" & lastRow)
    ' Initialize variables
    boxCounter = 1
    prevDistCenter = distCenterCol.Cells(2).Value
    boxCode = "BOX-" & Format(boxCounter, "000")
    totalBooks = 0
    boxSubjects = ""
    ' Loop through each row in the data
    Dim j As Long, schoolBooks As Long, remainingBooks As Long
    Dim distCenter As String, School As String, Subject As String
    For i = 1 To lastRow - 1
        distCenter = distCenterCol.Cells(i).Value
        School = schoolCol.Cells(i).Value
        Subject = subjectCol.Cells(i).Value
        remainingBooks = quantityCol.Cells(i).Value
        schoolBooks = remainingBooks
        ' Exclude schools with quantity 100 or more
        If remainingBooks >= 100 Then
            codeCol.Cells(i).Value = "Excluded"
        Else
            For j = i + 1 To lastRow
                If prevDistCenter = distCenterCol.Cells(j).Value And _
                    School = schoolCol.Cells(j).Value And _
                    quantityCol.Cells(j).Value < 100 Then
                    schoolBooks = schoolBooks + quantityCol.Cells(j).Value
                Else
                    Exit For
                End If
            Next
            ' Check if distribution center changes or adding the books exceeds the box limit
            If distCenter <> prevDistCenter Or totalBooks + schoolBooks > 300 Or _
                    (InStr(1, boxSubjects, "English") = 0 And _
                    InStr(1, boxSubjects, "Social & Religious Studies") = 0) Then
                ' Start a new box
                boxCounter = boxCounter + 1
                boxCode = Left(distCenter, 3) & "BOXENGSOC" & Format(boxCounter, "000")
                totalBooks = remainingBooks
                boxSubjects = Subject
            Else
                totalBooks = totalBooks + remainingBooks
                boxSubjects = boxSubjects & ", " & Subject
            End If
            ' Update the box code in column K
            codeCol.Cells(i).Value = boxCode
            ' Update the previous distribution center
            prevDistCenter = distCenter
        End If
    Next i
End Sub

    enter image description here