VBA generate next number with part string and store it in specific workbook.

[Kra]

Hi all,

I want to know if there is more efficient way to get what this macro does. So I need macro to generate next number. But the number is part of string. This how numbers look like for example:
1X0001223
1K0000244
1Q0000098

They always starts with 1 and some letter. Then there is 7 digits number. Currently I have specific command button for each number, so 1X if I want to generate 1X* number, button with 1K if I want generate 1K* number etc.
There is a workbook which stores these numbers. When I click command button, 1X for example, it opens this workbook, goes to "1K" sheet, finds last row and creates new number in a row below, then it copies it and pastes in selected cell in original workbook.
But the problem is that it ignores 0 between 1X and last number, so I had to add line to check last 4 characters in string and then add 1 to them. When I skipped it it resulted 1X1224 as next number, instead of 1X0001224. But also when I will go up to 1X0009999 number, it will create 1X00010000 instead of replacing 0 to the left with 1 (all materials are 9 digits total long). Any ideas how to make it more efficient, so I don't have to change macro each time?

Private Sub CommandButton7_Click()
    
    Dim LastRow As Long
    Dim x As Integer
    Dim rng As range

    Dim FPath As String
    Dim wb As Workbook
    Dim wb1 As Workbook: Set wb1 = ActiveWorkbook

Application.ScreenUpdating = False




    FPath = "C:\Local\KR\Numbers.xlsm"

    Set wb = Workbooks.Open(FPath)
    Dim ws As Worksheet: Set ws = wb.Sheets("1X")

    wb.Activate
    ws.Activate

    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

    x = LastRow

    Set rng = ActiveSheet.Cells(x, 1)

        rng.Offset(1, 0).Value = "1X000" & Right(rng, 4) + 1
        rng.Offset(1, 1).Value = Date
        rng.Offset(1, 2).Value = Format(Now, "HH:MM")
        rng.Offset(1, 3).Value = Application.UserName
        rng.Offset(1, 0).Copy

    wb1.Activate
    
    ActiveCell.PasteSpecial Paste:=xlPasteValues

    wb.Close True

Application.ScreenUpdating = True

End Sub

 

[Sparcot]

Hello. Not tested. Test it and report:

Private Sub CommandButton7_Click()
    Dim LastRow As Long
    Dim x As Integer
    Dim rng As Range
    Dim FPath As String
    Dim wb As Workbook
    Dim wb1 As Workbook: Set wb1 = ActiveWorkbook
    Dim textNumber As String
    Dim testNumber As Long
    Application.ScreenUpdating = False
    FPath = "C:\Local\KR\Numbers.xlsm"
    Set wb = Workbooks.Open(FPath)
    Dim ws As Worksheet: Set ws = wb.Sheets("1X")
    wb.Activate
    ws.Activate
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    x = LastRow
    Set rng = ActiveSheet.Cells(x, 1)
    textNumber = Right(rng, 7)
    testNumber = CInt(textNumber) + 1
    If testNumber > 0 And testNumber < 9 Then
        textNumber = "000000" & testNumber
    ElseIf testNumber > 10 And testNumber < 99 Then
        textNumber = "00000" & testNumber
    ElseIf testNumber > 100 And testNumber < 999 Then
        textNumber = "0000" & testNumber
    ElseIf testNumber > 1000 And testNumber < 9999 Then
        textNumber = "000" & testNumber
    ElseIf testNumber > 10000 And testNumber < 99999 Then
        textNumber = "00" & testNumber
    ElseIf testNumber > 100000 And testNumber < 999999 Then
        textNumber = "0" & testNumber
    ElseIf testNumber > 1000000 And testNumber < 9999999 Then
        textNumber = testNumber
    Else
        MsgBox "The number is too big"
        Exit Sub
    End If
    rng.Offset(1, 0).Value = "1X" & textNumber
    rng.Offset(1, 1).Value = Date
    rng.Offset(1, 2).Value = Format(Now, "HH:MM")
    rng.Offset(1, 3).Value = Application.UserName
    rng.Offset(1, 0).Copy
    wb1.Activate
    ActiveCell.PasteSpecial Paste:=xlPasteValues
    wb.Close True
    Application.ScreenUpdating = True
End Sub

 

[HaHoBe]

Hi Kra,

maybe use

        rng.Offset(1, 0).Value = Left(rng.Value, 2) & Right("000000" & CLng(Mid(rng.Value, 3)) + 1, 7)
        rng.Offset(1, 1).Value = Date
        rng.Offset(1, 2).Value = Format(Time, "HH:MM")
        rng.Offset(1, 3).Value = Application.UserName

Ciao,
Holger

 

[HaHoBe]

Hi Kra,

and do you really create a button for each combination? The sniplet I showed does not rely on a special set of number and character so maybe change the way to handle this into using a UserForm, a listbox or combobox holding the combinations to work with and two buttons (Cancel will be active on Initialize/Activate, the other is disabled until you choose an item in the list and will take that for the sheetname to activate and work on). It's up to your taste if you just want one number to be created and close the userform thereafter or deselect the item and disable the button for the next run.

Just my 2 cents on this.
Holger

 

[Kra]

Hello. Not tested. Test it and report:

Private Sub CommandButton7_Click()
    Dim LastRow As Long
    Dim x As Integer
    Dim rng As Range
    Dim FPath As String
    Dim wb As Workbook
    Dim wb1 As Workbook: Set wb1 = ActiveWorkbook
    Dim textNumber As String
    Dim testNumber As Long
    Application.ScreenUpdating = False
    FPath = "C:\Local\KR\Numbers.xlsm"
    Set wb = Workbooks.Open(FPath)
    Dim ws As Worksheet: Set ws = wb.Sheets("1X")
    wb.Activate
    ws.Activate
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
    x = LastRow
    Set rng = ActiveSheet.Cells(x, 1)
    textNumber = Right(rng, 7)
    testNumber = CInt(textNumber) + 1
    If testNumber > 0 And testNumber < 9 Then
        textNumber = "000000" & testNumber
    ElseIf testNumber > 10 And testNumber < 99 Then
        textNumber = "00000" & testNumber
    ElseIf testNumber > 100 And testNumber < 999 Then
        textNumber = "0000" & testNumber
    ElseIf testNumber > 1000 And testNumber < 9999 Then
        textNumber = "000" & testNumber
    ElseIf testNumber > 10000 And testNumber < 99999 Then
        textNumber = "00" & testNumber
    ElseIf testNumber > 100000 And testNumber < 999999 Then
        textNumber = "0" & testNumber
    ElseIf testNumber > 1000000 And testNumber < 9999999 Then
        textNumber = testNumber
    Else
        MsgBox "The number is too big"
        Exit Sub
    End If
    rng.Offset(1, 0).Value = "1X" & textNumber
    rng.Offset(1, 1).Value = Date
    rng.Offset(1, 2).Value = Format(Now, "HH:MM")
    rng.Offset(1, 3).Value = Application.UserName
    rng.Offset(1, 0).Copy
    wb1.Activate
    ActiveCell.PasteSpecial Paste:=xlPasteValues
    wb.Close True
    Application.ScreenUpdating = True
End Sub

Thank you, this works, I just changed rules >1000 <9999 to =>1000 =<9999 to include these numbers in calculations

 

[Kra]

Hi Kra,

maybe use

        rng.Offset(1, 0).Value = Left(rng.Value, 2) & Right("000000" & CLng(Mid(rng.Value, 3)) + 1, 7)
        rng.Offset(1, 1).Value = Date
        rng.Offset(1, 2).Value = Format(Time, "HH:MM")
        rng.Offset(1, 3).Value = Application.UserName

Ciao,
Holger

Hi Holger,

Thank you, works as well!

 

[Kra]

Hi Kra,

and do you really create a button for each combination? The sniplet I showed does not rely on a special set of number and character so maybe change the way to handle this into using a UserForm, a listbox or combobox holding the combinations to work with and two buttons (Cancel will be active on Initialize/Activate, the other is disabled until you choose an item in the list and will take that for the sheetname to activate and work on). It's up to your taste if you just want one number to be created and close the userform thereafter or deselect the item and disable the button for the next run.

Just my 2 cents on this.
Holger

Good point, I just started my VBA journey so I don't feel confided with creating more advanced user forms, but I will check this solution

 

[HaHoBe]

Hi Kra,

and what about setting up a table holding first and last number as well as the combination to work with and use either the BeforeRight or DoubeClick event behind the sheet in a given column of that table?

Ciao,
Holger

 

[Kra]

Hi Kra,

and what about setting up a table holding first and last number as well as the combination to work with and use either the BeforeRight or DoubeClick event behind the sheet in a given column of that table?

Ciao,
Holger

I love idea with DoubleClick, but this macro will be stored in PERSONAL.XLSB and used in many workbooks, so I am not able to set it up

 

[dmt32]

Hi,

Seen your post late in the day & appreciate have a solution but you may like to consider rather than have your number in the Numbers Workbook stored as string you create a custom number format that allows you to manage them as numbers - this will remove the need for any string manipulation.

Also, you would just have one common code that you pass the required number prefix (sheet name) to as an argument

Place in standard module

Sub GetNextNumber(ByVal Prefix As String)
    
    Dim LastRow     As Long
    Dim rng         As Range, numbercell As Range
    Dim strNumber   As String
    Dim wbNumbers   As Workbook
    Dim wsNumber    As Worksheet
    
    Application.ScreenUpdating = False
    
    Const FPath     As String = "C:\Local\KR\Numbers.xlsm"
    
    'the number cell
    Set numbercell = ActiveCell
    'or to avoid need to select required cell
    'qualify the sheet / range (update as required)
    'Set numbercell = ThisWorkbook.Worksheets("My Sheet Name").Range("B10")
    
    On Error GoTo myerror
    
    Set wbNumbers = Workbooks.Open(FPath, 0, False)
    Set wsNumber = wbNumbers.Worksheets(Prefix)
    
    LastRow = wsNumber.Cells(wsNumber.Rows.Count, 1).End(xlUp).Row
    
    Set rng = wsNumber.Cells(LastRow, 1)
    
    With rng
        'ensure last entry is numeric
        If Not IsNumeric(.Value) Then .Value = Val(Mid(.Value, 3))
        'apply custom format
        .NumberFormat = Prefix & "0000000"
        With .Offset(1, 0)
            'add next number
            .Value = rng.Value + 1
            .NumberFormat = rng.NumberFormat
            'get number as string
            strNumber = .Text
        End With
        .Offset(1, 1).Value = Date
        .Offset(1, 2).Value = Format(Now, "HH:MM")
        .Offset(1, 3).Value = Environ("UserName")
    End With
    
    'update number cell
    numbercell.Value = strNumber
    
myerror:
    'close workbook & save if no error
    If Not wbNumbers Is Nothing Then wbNumbers.Close Err = 0
    Application.ScreenUpdating = True
    'report errors
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
    
End Sub

And to call it just specify the required prefix (sheet name) 1X, 1Q etc from your buttons or however you want to call the code.

Sub CommandButton7_Click()
    GetNextNumber "1X"
End Sub

Sub CommandButton8_Click()
    GetNextNumber "1Q"
End Sub

Hope Helpful

Dave