Sub ConvertEuroDates()
Din cell as Range
Dim strDay As String, strMonth As String, strYear As String
Dim intP1 As Integer, intP2 As Integer, intResponse as Integer
' Abort if a range isn't selected
If TypeName(Selection) <> "Range" Then
MsgBox "Please select a range of cells", vbOKOnly + vbInformation, "Invalid Range Selection"
Exit Sub
End If
' On Error GoTo exitsub
intResponse = MsgBox("Click Yes to convert Euro dates (dd.mm.yy) to US dates (mm/dd/yy)" & vbCrLf & "Click No to convert US dates to Euro dates" & vbCrLf & "Click Cancel to exit", vbYesNoCancel, "Convert Dates")
If intResponse = vbCancel Then Exit Sub
Application.ScreenUpdating = False
If intResponse = vbYes Then
Application.Calculation = xlCalculationManual
For Each Cell In Selection
On Error Resume Next
intP1 = Application.WorksheetFunction.Find(".", Cell.Value)
If Err <> 0 Then
strDay = Application.WorksheetFunction.Substitute(Left(Cell.Text, 2), "/", "")
strMonth = Application.WorksheetFunction.Substitute(Mid(Cell.Text, 4, 2), "/", "")
strYear = Application.WorksheetFunction.Substitute(Right(Cell.Text, 2), "/", "")
If strMonth > 12 Or strDay > 31 Then
'Do Nothing
Else
Cell.Value = strDay & "/" & strMonth & "/" & strYear
End If
On Error GoTo 0
GoTo NextCell
End If
intP2 = Application.WorksheetFunction.Find(".", Cell.Value, intP1 + 1)
strDay = Left(Cell.Text, intP1 - 1)
strMonth = Mid(Cell.Text, intP1 + 1, intP2 - intP1 - 1)
strYear = Right(Cell.Text, Len(Cell.Text) - intP2)
If CInt(strMonth) > 12 Or CInt(strDay) > 31 Then
MsgBox "The value in cell " & Cell.Address & " (" & Cell.Value & ") cannot be converted"
GoTo NextCell
End If
Cell.Value = strMonth & "/" & strDay & "/" & strYear
NextCell:
On Error GoTo 0
Next Cell
ActiveCell.EntireColumn.AutoFit
End If
If intResponse = vbNo Then
Selection.NumberFormat = "mm/dd/yy"
For Each Cell In Selection
strMonth = Left(Cell.Text, 2)
strDay = Mid(Cell.Text, 4, 2)
strYear = Right(Cell.Text, 2)
Cell.Value = strDay & "." & strMonth & "." & strYear
Next Cell
ActiveCell.EntireColumn.AutoFit
End If
exitsub:
If Err <> 0 Then
MsgBox "An Error Occurred: " & Err.Number & " " & Err.Description, vbOKOnly + vbExclamation, "File Open Error"
On Local Error GoTo 0
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub