Set Cell To Display Number(s) Entered In Four-Digit Format

Hi everyone,

I need to set up Cell C4 on my sheet to convert data entered to this format:

If a 1 is entered, it would convert to 0010.
A 9 would equal 0090.
15 = 0150
46 = 0460
320 = 3200
9-46 = 0090-0460
15-320 = 0150-3200
0700 = 0700

As you can see, it basically needs to convert any three-digit number or less to a four-digit format, with a 0 at the end and 0's at the front as required.

Now, I have this half-way working with this formula which romperstomper helped me with here.

For Each rngCell In Intersect(Target, rngMonitor).Cells
            If Val(rngCell.Text) > 0 Then
                If Len(rngCell.Text) < 4 Then
                    rngCell.Value = Right("000" & rngCell.Text, 3) & "0"
                ElseIf Len(rngCell.Text) > 4 Then
                    MsgBox "Entry is too long!"
                    rngCell.ClearContents
                End If
            End If
        Next rngCell

This has been working great if only one number was entered, but now I've come across the problem where sometimes a '-' will need to be used to specify a range of numbers, such as 0090-0460. How could this current code be altered to check each 'group' of numbers, and if they are not already entered in the correct format, change them to the four-digit format as shown above?

Maybe try this:

Dim D%

For Each rngcell In Intersect(Target, rngMonitor).Cells
    If Val(rngcell.Text) > 0 Then
        D = InStr(1, rngcell.Text, "-", vbTextCompare)
        If D > 0 Then
            rngcell.Text = Format(Left(rngcell.Text, D - 1), "000") & "0-" & Format(Right(rngcell.Text, D - 1), "000") & "0"
        ElseIf Len(rngcell.Text) < 4 Then
            rngcell.Text = Right("000" & rngcell.Text, 3) & "0"
        Else
            MsgBox "Entry is too long!"
            rngcell.ClearContents
        End If
    End If
Next

Thank you so much for your reply! Any idea why I'm getting an 'Object Required' error when I try to enter a value in Cell C4?

Which line of code is giving you the error. I wrote it from scratch using different object names and then converted it to fit with your code so it might need a slight tweak.

I'm not even sure, the message just pops up, I hit OK, and I'm not taken to the code.

Here is my entire code for that sheet, as it was before adding yours:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngCell As Range
    Dim rngMonitor As Range
    On Error GoTo err_handle

    'If 'Entry Page'!F7 changes:
    If Not Intersect(Target, Me.Range("$F$7")) Is Nothing Then
        Application.EnableEvents = False
        Select Case Len(Trim(Target.Text))
            Case 0:         Sheets("Inspection Report").Range("L6, L86, L166").Value = ""
                            Sheets("Inspection Report").Range("C77, C157, C237").Value = ""
            
            Case Is <= 21:  Sheets("Inspection Report").Range("L6, L86, L166").Value = Target.Text
                            Sheets("Inspection Report").Range("C77, C157, C237").Value = ""
            
            Case Else:      Sheets("Inspection Report").Range("L6, L86, L166").Value = "See Notes"
                            Sheets("Inspection Report").Range("C77, C157, C237").Value = Target.Text
        End Select
        Application.EnableEvents = True
    End If

       If Target.Address = "$F$22" Then
        If Target.Value > 0 Then Exit Sub
        Application.EnableEvents = False
        If Target.Value = "" Then MsgBox "You need to print at least 1 label!"
        Target.Value = 1
        Application.EnableEvents = True
    End If

    ' adjust to whatever cells you want to monitor
    Set rngMonitor = Range("C4")

    If Not IsValidFileName(ThisWorkbook.Name) Then
        MsgBox "Please save the file as <partnumber>Rev<revision number> before entering data!"
        On Error Resume Next
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With
        Exit Sub
    End If

    If Not Intersect(Target, Range("C8,C12")) Is Nothing Then
        MsgBox "Do not change the part number or revision number. Save the file as the relevant name and the numbers will change automatically."
        On Error Resume Next
        With Application
            .EnableEvents = False
            .Undo
            .EnableEvents = True
        End With
        Exit Sub
    End If

    If Not Intersect(Target, rngMonitor) Is Nothing Then

        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

        For Each rngCell In Intersect(Target, rngMonitor).Cells
            If Val(rngCell.Text) > 0 Then
                If Len(rngCell.Text) < 4 Then
                    rngCell.Value = Right("000" & rngCell.Text, 3) & "0"
                ElseIf Len(rngCell.Text) > 4 Then
                    MsgBox "Entry is too long!"
                    rngCell.ClearContents
                End If
            End If
        Next rngCell

    End If

    If Not Intersect(Target, Range("NameCells")) Is Nothing Then
        For Each rngCell In Intersect(Target, Range("NameCells"))
            UpdatePics rngCell.Offset(, -1).Name.Name, rngCell.Value
        Next rngCell
    End If

clean_up:
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Exit Sub

err_handle:
    MsgBox Err.Description
    Resume clean_up

End Sub

Try removing the error handler and when you get the error, click on Debug. That will highlight the row causing the problem

How do I go about removing the error handler?

Remove the line:

On Error GoTo err_handle

Alright, it's this line: rngCell.Text = Right("000" & rngCell.Text, 3) & "0"

In the original code you posted it was .value instead of .text so try that

rngCell.Value = Right("000" & rngCell.Text, 3) & "0"

You know what? That nearly does it! The only issue I can still see is when I enter a 2-79, for example, it gets converted to '0020-0090' for some reason - any idea why?

From your examples, that's what I thought you wanted the output to be. What should the result be?

It's close, but if I enter 2-79, I should be getting a 0020-0790. Instead, I'm getting 0020-0090.

Don't have excel in front of me right now but try this

change:

Format(Right(rngcell.Text, D - 1), "000")

to:

Format(Right(rngcell.Text, D), "000")

Thanks, but that's still not working - I tried replacing just one of them to that, then the other, then both, but I'm getting all kinds of weird results back.

This is working for me. If you are still having problems then upload a workbook so I can properly debug.

For Each rngcell In Intersect(Target, rngMonitor).Cells
    If Val(rngcell.Text) > 0 Then
        D = InStr(1, rngcell.Text, "-", vbTextCompare)
        If D > 0 Then rngcell.Value = Format(Left(rngcell.Text, D - 1), "000") & "0-" & Format(Right(rngcell.Text, D), "000") & "0"
        ElseIf Len(rngcell.Text) < 4 Then rngcell.Text = Right("000" & rngcell.Text, 3) & "0"
        Else
            MsgBox "Entry is too long!"
            rngcell.ClearContents
        End If
    End If
Next

Alright, thank you - here is my sample. Notice I tried to use your latest code, but I deleted an 'End If' as it was giving me an error. And now, entering a 4 doesn't change to 0040; entering 22-55 turns into 0220--0550 which is one too many dashes in there. Entering 2-79 returns 0020-0790, which is perfect.

PS You'll notice an error upon opening the workbook - just click End, that's due to the fact that this is a sample workbook with sheets missing, but it won't interfere with what we're doing here.

This should work now:

    If Not Intersect(Target, rngMonitor) Is Nothing Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        For Each rngCell In Intersect(Target, rngMonitor).Cells
            If Val(rngCell.Text) > 0 Then
                D = InStr(1, rngCell.Text, "-", vbTextCompare)
                If D > 0 Then
                    rngCell.Value = Format(Left(rngCell.Text, D - 1), "000") & "0" & Format(Right(rngCell.Text, D), "000") & "0"
                ElseIf Len(rngCell.Text) < 4 Then
                    rngCell.Value = Right("000" & rngCell.Text, 3) & "0"
                Else
                    MsgBox "Entry is too long!"
                    rngCell.ClearContents
                End If
            End If
        Next
    End If

Thanks again! We've almost got it!

This works!:
2-5 = 0020-0050
22-55 = 0220-0550
222-555 = 2220-5550

This doesn't:
2-55 = 00200550
2-555 = 00200550

It seems to get hung up when the number of digits in each group aren't the same..

Yes, I see my mistake. It should be:

rngCell.Value = Format(Left(rngCell.Text, D - 1) * 10, "0000") & "-" & Format(Right(rngCell.Text, Len(rngCell.Text) - D) * 10, "0000")

instead of:

rngCell.Value = Format(Left(rngCell.Text, D - 1), "000") & "0" & Format(Right(rngCell.Text, D), "000") & "0"

That's it! Thank you so very much!

Glad it worked out. If you are satisfied with the responses then please mark the thread as solved.

Good luck.

abousetta