Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count = 1 Then
        Dim dic As Object
        Set dic = CreateObject("Scripting.Dictionary")
        Dim sTarget As String
        Dim ss As String
        Dim sAdd As String
        Dim sRes As String
        sTarget = Target.Value
        Dim flag As Boolean
        Dim xx As Long
        Dim ii As Long
        For xx = 1 To Len(sTarget)
            ss = Mid(sTarget, xx, 1)
            If IsNumeric(ss) Then
                sAdd = ss
                If flag Then
                    If dic.Exists(ss) Then
                        For ii = Int(ss) + 1 To 9
                            If Not dic.Exists(CStr(ii)) Then
                                sAdd = CStr(ii)
                                Exit For
                            End If
                        Next
                        If sAdd = ss Then
                            For ii = Int(ss) - 1 To 0 Step -1
                                If Not dic.Exists(CStr(ii)) Then
                                    sAdd = CStr(ii)
                                    Exit For
                                End If
                            Next
                        End If
                    End If
                Else
                    flag = True
                End If
                sRes = sRes & sAdd
                dic.Item(sAdd) = 0
            End If
        Next
        Application.EnableEvents = False
        Target = sRes
        Application.EnableEvents = True
    End If
End Sub

Sub ChangeDigit()
  Dim a, b&, c&, d&(), e&(), i&, r&, s
  Randomize
  a = [a1].CurrentRegion
  For r = 1 To UBound(a)
    ReDim d(0 To 9): s = Replace("" & a(r, 1), ",", "."): ReDim e(1 To Len(s))
    For i = 1 To Len(s)
      If Mid(s, i, 1) <> "." Then
        c = Val(Mid(s, i, 1)): If d(c) = 1 Then e(i) = 1 Else d(c) = 1
      End If
    Next
    For i = 2 To Len(s)
      If e(i) Then
        Do: b = Int(Rnd * 10): Loop Until d(b) = 0
        d(b) = 1: Mid(s, i, 1) = b
      End If
    Next
    a(r, 1) = Val(s)
  Next
  [b1].Resize(UBound(a), 1) = a
End Sub