求可自动为日期格式单元格添加分隔符的VBA代码

Here's a modified Worksheet_Change event that will automatically convert a 6-digit string (like 010101) to a formatted date (like 01/01/2001) when you move away from the cell. This version handles date validation, avoids infinite loops, and works with both text and properly formatted number inputs (though text format is recommended to preserve leading zeros).

The VBA Code #

Private Sub Worksheet_Change(ByVal Target As Range)
    ' Disable events to prevent infinite loop when modifying the cell
    Application.EnableEvents = False
    On Error GoTo Cleanup ' Ensure events are re-enabled even if an error occurs

    ' Only process single-cell changes (skip bulk edits)
    If Target.Cells.Count > 1 Then GoTo Cleanup

    Dim inputStr As String
    inputStr = Trim(Target.Value)

    ' Check if input is exactly 6 digits
    If Len(inputStr) = 6 And IsNumeric(inputStr) Then
        Dim dayPart As String, monthPart As String, yearPart As String
        Dim convertedDate As Date

        ' Split the 6-digit string into date components
        ' **Adjust the order here if your input uses MMDDYY instead of DDMMYY**
        dayPart = Left(inputStr, 2)    ' First two digits = day
        monthPart = Mid(inputStr, 3, 2) ' Middle two digits = month
        yearPart = Right(inputStr, 2)   ' Last two digits = year (2-digit)

        ' Convert to 4-digit year (assumes 2000-2099; modify for 19xx support if needed)
        yearPart = "20" & yearPart

        ' Create a valid date object
        convertedDate = DateSerial(CInt(yearPart), CInt(monthPart), CInt(dayPart))

        ' Assign the date to the cell and set your desired date format
        Target.Value = convertedDate
        Target.NumberFormat = "dd/mm/yyyy" ' Use "mm/dd/yyyy" for month/day/year format
    End If

Cleanup:
    ' Re-enable events regardless of success/failure
    Application.EnableEvents = True
    ' Show error message if invalid date was entered
    If Err.Number <> 0 Then
        MsgBox "Invalid date entered: " & Target.Value & vbCrLf & "Error: " & Err.Description, vbExclamation
        Err.Clear
    End If
End Sub

How to Use This Code #

1. Open your Excel workbook.
2. Press Alt + F11 to open the VBA Editor.
3. In the Project Explorer (left pane), double-click the worksheet where you want this functionality to work.
4. Paste the code into the code window that appears.
5. Close the VBA Editor and test it by entering a 6-digit value (like 010101) in a cell and pressing Enter.

Key Notes #

• Leading Zeros: To preserve leading zeros (e.g., entering 010101 instead of 10101), set your target cells to Text format before entering values. If you use Number format, leading zeros will be stripped, and the code won't process 5-digit inputs.
• Date Order: If your input uses MMDDYY (month-day-year) instead of DDMMYY, swap the dayPart and monthPart lines:

  monthPart = Left(inputStr, 2)
  dayPart = Mid(inputStr, 3, 2)
  

• Year Range: The code assumes 2-digit years are from 2000-2099. If you need to handle 19xx years (e.g., 99 = 1999), add logic to check the year part and adjust accordingly (e.g., If CInt(yearPart) > 50 Then yearPart = "19" & yearPart Else yearPart = "20" & yearPart).
• Error Handling: If you enter an invalid date (like 310201 for 31st February), the code will show an error message and leave the original input intact.

内容的提问来源于stack exchange，提问作者sergio trajano