Hi Igor,
The code was changed to meet your new requirements. See the attached file which contains:
UserForm Code:
Option Explicit
Private Sub Country_Change()
Dim sValue As String
'Prevent Runtime error caused by manual entry
'Get the Country Code
On Error Resume Next
sValue = Application.VLookup(Country.Value, Range("Country_code"), 2, False)
If Err.Number = 0 Then
TextBoxCountryCode = sValue
Else
TextBoxCountryCode = ""
End If
On Error GoTo 0
'Update the Next Code Number (similar to changing Vehicle Type)
Call ComboBoxVehicle_Type_Change
End Sub
Private Sub ComboBoxVehicle_Type_Change()
'This processes a 'ComboBox' Change
Dim sCountryName As String
Dim sNextProductCode As String
Dim sProductType As String
'Get the new 'Product Type'
sProductType = ComboBoxVehicle_Type.Value
'Get the new 'Country Name'
sCountryName = Country.Value
'Get the Next Product Code
sNextProductCode = CreateProductCode(sProductType, sCountryName)
'Update the UserForm from the Global Variables
TextBoxNextFleet_Number = sNextProductCode
'Display or Hide Results Controls as required
Call DisplayOrHideUserFormControls
End Sub
Private Sub DisplayOrHideUserFormControls()
Dim sCountryCode As String
Dim sNextProductType As String
'Get the new 'Country Name' (with leading and trailing spaces removed)
sCountryCode = Trim(TextBoxCountryCode.Value)
'Get the 'Next Product Type' (with leading and trailing spaces removed)
sNextProductType = Trim(TextBoxNextFleet_Number.Value)
'Display the 'Country Code' only if there is a 'Country Name'
If Len(sCountryCode) > 0 Then
LabelCountryCode.Visible = True
TextBoxCountryCode.Visible = True
Else
LabelCountryCode.Visible = False
TextBoxCountryCode.Visible = False
End If
'Display the Next Product Code only if the value is NOT BLANK
If Len(sNextProductType) > 0 Then
LabelNextFleet_Number.Visible = True
TextBoxNextFleet_Number.Visible = True
Else
LabelNextFleet_Number.Visible = False
TextBoxNextFleet_Number.Visible = False
End If
End Sub
Sheet 'Actual Situation' code module code:
Private Sub Worksheet_Change(ByVal Target As Range)
'This processes a change in the value of cell 'B1' or 'B2'
If Not Intersect(Target, Range("B1:B2")) Is Nothing Then
Dim sCountryName As String
Dim sProductType As String
Dim sNextProductNumber As String
'Get the Country Name from the SpreadSheet
'Get the Product Type from the SpreadSheet
sCountryName = Range("B1").Value
sProductType = Range("B2").Value
'Calculate the 'Next Product Number'
sNextProductNumber = CreateProductCode(sProductType, sCountryName)
'Put the 'Next Product Number' in Cell 'C3'
Range("C3").Value = sNextProductNumber
End If
End Sub
Ordinary Code Module Code Module ModCreateProductCode:
Option Explicit
Public Const sActualDataSheetNAME = "Actual situation"
Public Const sActualDataSheetDataStartRANGE = "C6:C"
Public Const sMasterCodeSheetNAME = "Pickup_list"
Function CreateProductCode(sProductType As String, sCountryName As String) As String
'This returns the Next Product Number of a given input Product Type
'If there is an error an EMPTY STRING "" is returned.
'
'NOTE: Match function is ALWAYS case insensitive
Const nExactMATCH = 0
Dim wsActualData As Worksheet
Dim wsCodeMaster As Worksheet
Dim myRangeConstants As Range
Dim myRangeSingleLetters As Range
Dim myRangeLetterAndNumberCodes As Range
Dim iIndex1 As Long
Dim iIndex2 As Long
Dim iIndex3 As Long
Dim iIndex4 As Long
Dim iCodeColumn As Long
Dim iCountryRow As Long
Dim iCountryNamesColumn As Long
Dim iMaxCodes As Long
Dim iMaxCodesPerSingleLetter As Long
Dim iNextCodeNumber As Long
Dim iNumberOfCodesInUseForThisProductType As Long
Dim iNumberOfProductSingleLetterCodes As Long
Dim iNumberOfLetterAndNumberCodes As Long
Dim iNumbersAndLettersColumn As Long
Dim iRemainder As String
Dim iSequenceNumber As Long
Dim s1 As String
Dim s2 As String
Dim s3 As String
Dim s4 As String
Dim sAddressesInRange As String
Dim sColumnSingleLetters As String
Dim sColumnLetterAndNumberCodes As String
Dim sCountryCode As String
Dim sLastExistingProductCode As String
Dim sNextProductCode As String
Dim sRange As String
''''''''''''''''''''''''''''''''''''''''''''''
'Create the Worksheet objects
''''''''''''''''''''''''''''''''''''''''''''''
Set wsActualData = ThisWorkbook.Sheets(sActualDataSheetNAME)
Set wsCodeMaster = ThisWorkbook.Sheets(sMasterCodeSheetNAME)
''''''''''''''''''''''''''''''''''''''''''''''
'Find the Column Number in Row 1 that matches the input Product Type
'A Runtime Error is Generated if there is no match
''''''''''''''''''''''''''''''''''''''''''''''
On Error GoTo MYEXIT
iCodeColumn = Application.WorksheetFunction.Match(sProductType, wsCodeMaster.Range("1:1"), nExactMATCH)
''''''''''''''''''''''''''''''''''''''''''''''
'Get 'Single Letter' Codes Data
''''''''''''''''''''''''''''''''''''''''''''''
'Convert the Column to a String
'Create a Column Range (e.g. 'J:J')
'Find the Range of Values in the Column (may contain non-contiguous data not in the range)
'Find the Contiguous Range using the Intersect with the Current Region
'Get the number of 'Single Letter' Codes
sColumnSingleLetters = LjmExcelColumnNumberToChar(iCodeColumn)
sRange = sColumnSingleLetters & ":" & sColumnSingleLetters
Set myRangeConstants = wsCodeMaster.Range(sRange).SpecialCells(xlCellTypeConstants)
'Debug.Print myRangeConstants.Address(False, False)
sAddressesInRange = myRangeConstants.Address(False, False) '(False, False) removes '$' signs from addresses
Set myRangeSingleLetters = Intersect(myRangeConstants, wsCodeMaster.Cells(1, sColumnSingleLetters).CurrentRegion)
'Debug.Print myRangeSingleLetters.Address(False, False)
iNumberOfProductSingleLetterCodes = myRangeSingleLetters.Count - 1 'Omit Header
''''''''''''''''''''''''''''''''''''''''''''''
'Find the Column Number in Row 1 that contains the Code Numbers and Letters
''''''''''''''''''''''''''''''''''''''''''''''
iNumbersAndLettersColumn = Application.WorksheetFunction.Match("Numbers And Letters", wsCodeMaster.Range("1:1"), nExactMATCH)
''''''''''''''''''''''''''''''''''''''''''''''
'Get 'Code Numbers and Letters' Data
''''''''''''''''''''''''''''''''''''''''''''''
'Convert the Column to a String
'Create a Column Range (e.g. 'J:J')
'Find the Range of Values in the Column (may contain non-contiguous data not in the range)
'Find the Contiguous Range using the Intersect with the Current Region
'Get the number of 'Letter and Numbers' Codes
sColumnLetterAndNumberCodes = LjmExcelColumnNumberToChar(iNumbersAndLettersColumn)
sRange = sColumnLetterAndNumberCodes & ":" & sColumnLetterAndNumberCodes
Set myRangeConstants = wsCodeMaster.Range(sRange).SpecialCells(xlCellTypeConstants)
'Debug.Print myRangeConstants.Address(False, False)
sAddressesInRange = myRangeConstants.Address(False, False) '(False, False) removes '$' signs from addresses
Set myRangeLetterAndNumberCodes = Intersect(myRangeConstants, wsCodeMaster.Cells(1, sColumnLetterAndNumberCodes).CurrentRegion)
'Debug.Print myRangeLetterAndNumberCodes.Address(False, False)
iNumberOfLetterAndNumberCodes = myRangeLetterAndNumberCodes.Count - 2 'Omit Header and Last Line
''''''''''''''''''''''''''''''''''''''''''''''
'Find the Column Number in Row 1 that contains the Country Names
''''''''''''''''''''''''''''''''''''''''''''''
iCountryNamesColumn = Application.WorksheetFunction.Match("Country", wsCodeMaster.Range("1:1"), nExactMATCH)
''''''''''''''''''''''''''''''''''''''''''''''
'Get the 'Country Code'
''''''''''''''''''''''''''''''''''''''''''''''
'Convert the Column to a String
'Create a Column Range (e.g. 'J:J')
'Find the Row that contains the 'Country Name' and 'Country Code'
'Find the Range of Values in the Column (may contain non-contiguous data not in the range)
'Find the Contiguous Range using the Intersect with the Current Region
'Get the number of 'Letter and Numbers' Codes
sColumnLetterAndNumberCodes = LjmExcelColumnNumberToChar(iCountryNamesColumn)
sRange = sColumnLetterAndNumberCodes & ":" & sColumnLetterAndNumberCodes
iCountryRow = Application.WorksheetFunction.Match(sCountryName, wsCodeMaster.Range(sRange), nExactMATCH)
sCountryCode = wsCodeMaster.Cells(iCountryRow, iCountryNamesColumn + 1).Value
''''''''''''''''''''''''''''''''''''''''''''''
'Calculate the Maximum Number of Codes
''''''''''''''''''''''''''''''''''''''''''''''
iMaxCodesPerSingleLetter = iNumberOfLetterAndNumberCodes ^ 3
iMaxCodes = iNumberOfProductSingleLetterCodes * iMaxCodesPerSingleLetter
''''''''''''''''''''''''''''''''''''''''''''''
'Get the Number of Codes Already in Use for this 'Product Type'
''''''''''''''''''''''''''''''''''''''''''''''
sRange = sActualDataSheetDataStartRANGE & Rows.Count
iNumberOfCodesInUseForThisProductType = Application.WorksheetFunction.CountIf(wsActualData.Range(sRange), sProductType)
''''''''''''''''''''''''''''''''''''''''''''''
'Get the Current Code Number (Last Existing)
''''''''''''''''''''''''''''''''''''''''''''''
If iNumberOfCodesInUseForThisProductType > 0 Then
'NOTE: MINUS 1 is used because the first code offset value is ZERO
iSequenceNumber = iNumberOfCodesInUseForThisProductType - 1
iIndex1 = iSequenceNumber \ iMaxCodesPerSingleLetter
iRemainder = iSequenceNumber - iIndex1 * iMaxCodesPerSingleLetter
iIndex2 = iRemainder \ (iNumberOfLetterAndNumberCodes * iNumberOfLetterAndNumberCodes)
iRemainder = iRemainder - iIndex2 * (iNumberOfLetterAndNumberCodes * iNumberOfLetterAndNumberCodes)
iIndex3 = iRemainder \ iNumberOfLetterAndNumberCodes
iRemainder = iRemainder - iIndex3 * iNumberOfLetterAndNumberCodes
iIndex4 = iRemainder
'Get the Values for each digit using Row 2 as a Base
s1 = wsCodeMaster.Cells(2, iCodeColumn).Offset(iIndex1, 0)
s2 = wsCodeMaster.Cells(2, iNumbersAndLettersColumn).Offset(iIndex2, 0)
s3 = wsCodeMaster.Cells(2, iNumbersAndLettersColumn).Offset(iIndex3, 0)
s4 = wsCodeMaster.Cells(2, iNumbersAndLettersColumn).Offset(iIndex4, 0)
'Create the 'Last Existing' Product Code String
sLastExistingProductCode = "Product_" & sCountryCode & s1 & s2 & s3 & s4
Else
'Create the 'Last Existing' Product Code String
sLastExistingProductCode = "None"
End If
'Set the value of CONDITIONAL COMPILATION Constant 'TEST_CODE_SEQUENCES' to 'True' to test a SEQUENCE of Product Codes
'Set the value of CONDITIONAL COMPILATION Constant 'TEST_CODE_SEQUENCES' to 'False' for NORMAL operation
#Const TEST_CODE_SEQUENCES = False
#If TEST_CODE_SEQUENCES = True Then
Dim iX As Long
For iX = 0 To 50000
#End If
''''''''''''''''''''''''''''''''''''''''''''''
'Get the Next Code Number to Use
''''''''''''''''''''''''''''''''''''''''''''''
iNextCodeNumber = iNumberOfCodesInUseForThisProductType + 1
'NOTE: MINUS 1 is used because the first code offset value is ZERO
iSequenceNumber = iNextCodeNumber - 1
iIndex1 = iSequenceNumber \ iMaxCodesPerSingleLetter
iRemainder = iSequenceNumber - iIndex1 * iMaxCodesPerSingleLetter
iIndex2 = iRemainder \ (iNumberOfLetterAndNumberCodes * iNumberOfLetterAndNumberCodes)
iRemainder = iRemainder - iIndex2 * (iNumberOfLetterAndNumberCodes * iNumberOfLetterAndNumberCodes)
iIndex3 = iRemainder \ iNumberOfLetterAndNumberCodes
iRemainder = iRemainder - iIndex3 * iNumberOfLetterAndNumberCodes
iIndex4 = iRemainder
'Get the Values for each digit using Row 2 as a Base
s1 = wsCodeMaster.Cells(2, iCodeColumn).Offset(iIndex1, 0)
s2 = wsCodeMaster.Cells(2, iNumbersAndLettersColumn).Offset(iIndex2, 0)
s3 = wsCodeMaster.Cells(2, iNumbersAndLettersColumn).Offset(iIndex3, 0)
s4 = wsCodeMaster.Cells(2, iNumbersAndLettersColumn).Offset(iIndex4, 0)
'Create the 'Next' Product Code String
'Code is 'ABCDDD'
' A = 'Product_'
' B = Two Character Country Code
' C = Sequential one Character code associated with a specific product
' DDD = Sequential 3 Character code associated with a specific product
sNextProductCode = "Product_" & sCountryCode & s1 & s2 & s3 & s4
Debug.Print iNextCodeNumber, sNextProductCode 'Output to Immediate Window (CTRL G in debugger)
#If TEST_CODE_SEQUENCES = True Then
iNumberOfCodesInUseForThisProductType = iNumberOfCodesInUseForThisProductType + 1
Next iX
#End If
'Set the return value
CreateProductCode = sNextProductCode
MYEXIT:
'Clear object pointers
Set wsActualData = Nothing
Set wsCodeMaster = Nothing
Set myRangeConstants = Nothing
Set myRangeSingleLetters = Nothing
Set myRangeLetterAndNumberCodes = Nothing
End Function
Private Function LjmExcelColumnNumberToChar(InputColumn As Long) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' This converts an Excel integer column number to "character column letter(s)"
' e.g. convert 1 to "A"
' e.g. convert 28 to "AB"
'
' This assumes 2 character column limitation of 702 columns = (26 * 27)
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If InputColumn > 26 Then
LjmExcelColumnNumberToChar = Chr(Int((InputColumn - 1) / 26) + 64) & Chr(((InputColumn - 1) Mod 26) + 65)
Else
LjmExcelColumnNumberToChar = Chr(InputColumn + 64)
End If
End Function
Please note that Option Explicit is very important. It is a best practice to declare all variables. If you misspell a variable in your code, VBA will silently assume it is a Variant variable and go on executing with no clue to you that you have a bug. Go to the VBA development window, click Tools, Options, and check "Require Variable Declaration." This will insert the following line at the top of all new modules:
This option requires all variables to be declared and will give a compiler error for undeclared variables.
Lewis
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks