简体   繁体   中英

Automatically add bars to date cells

I need a VBA code that inserts bars automatically in cells with date format.

I mean, you type 010101 in a cell and, after moving to the next, the cell converts 010101 to 01/01/2001 automatically.

I already have a code that insert bars, but it only works in cells with text format.

The code I have is as follows:

Private Sub Worksheet_Change(ByVal Target As Range)
 Set MyIntersect = Intersect(Target, Cells)
 If (Not (MyIntersect Is Nothing)) And (Not IsEmpty(MyIntersect)) Then
  Dim UserData As String: UserData = MyIntersect.Value
  If Right(UserData, 2) <= Mid(CStr(Year(Date)), 3, 2) Then
   UserData = Left(UserData, 4) & "20" & Right(UserData, 2)
  Else
   UserData = Left(UserData, 4) & "19" & Right(UserData, 2)
  End If
  UserData = Left(UserData, 2) & "/" & Mid(UserData, 3, 2) & "/" & _ 
  Right(UserData, 4)
  Application.EnableEvents = False
  MyIntersect.Value = UserData
  Application.EnableEvents = True
 End If
End Sub

I found the answer. The trick was to convert the intersection.value first to long and then to string, and add a zero to the string if its lenght is equal to five. The user must insert date as DDMMYY only, otherwise the code will not work, except if improved later.

The code is as follows:

Private Sub Worksheet_Change(ByVal Target As Range)
Set MyIntersect = Intersect(Target, Cells)
 If (Not (MyIntersect Is Nothing)) And (Not IsEmpty(MyIntersect)) Then
  Dim UserData As String: UserData = CStr(CLng(MyIntersect.Value))
  If Len(UserData) = 5 Then UserData = "0" & UserData
  If Right(UserData, 2) <= Mid(CStr(Year(Date)), 3, 2) Then
   UserData = Left(UserData, 4) & "20" & Right(UserData, 2)
  Else
   UserData = Left(UserData, 4) & "19" & Right(UserData, 2)
  End If
  UserData = Left(UserData, 2) & "/" & Mid(UserData, 3, 2) & "/" & _
  Right(UserData, 4)
  Application.EnableEvents = False
  MyIntersect.Value = UserData
  Application.EnableEvents = True
 End If
End Sub

The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM