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

K

Kra

Board Regular
Joined
Jul 4, 2022
Messages
160
Office Version
  1. 365
Platform
  1. Windows
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?


VBA Code: 
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
 

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Sort by date Sort by votes
Hello. Not tested. Test it and report:
VBA Code: 
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
 
Upvote 0
Solution
Hi Kra,

maybe use

VBA Code: 
        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
 
Upvote 0
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
 
Upvote 0
Sparcot said:
Hello. Not tested. Test it and report:
VBA Code: 
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
Click to expand...
Thank you, this works, I just changed rules >1000 <9999 to =>1000 =<9999 to include these numbers in calculations
 
Upvote 0
HaHoBe said:
Hi Kra,

maybe use

VBA Code: 
        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
Click to expand...
Hi Holger,

Thank you, works as well!
 
Upvote 0
HaHoBe said:
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
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
HaHoBe said:
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
Click to expand...
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
 
Upvote 0
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

Code: 
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.

Code: 
Sub CommandButton7_Click()
    GetNextNumber "1X"
End Sub

Sub CommandButton8_Click()
    GetNextNumber "1Q"
End Sub

Hope Helpful

Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Question
Multiple VBA codes on sheet1
Replies
1
Views
153
skillilea
S
C
  • Question
A Bookmark to return to the same row when exiting and opening the application
Replies
8
Views
149
Edgar_
Edgar_
N
  • Question
VBA - Copying specific data to open workbook.
Replies
1
Views
293
eiloken
E
H
  • Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
117
harmless92
H
G
  • Solved
Format & Protect range of cells using VBA
Replies
7
Views
250
Gajendran Yadhav
G

Forum statistics

Threads
1,214,515
Messages
6,119,973
Members
448,933
Latest member
Bluedbw

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top