Сокращение после запятой

[Pavel55]

Ох, не знаю, тут или вы сами поправите код, как вам надо или, может, Pashulka Вам поможет.

[Romuald]

Никак не идет

[Romuald]

Кто знает , как сделать, помогите пожалуйста

[Romuald]

SAS888
Посмотрите, пожалуйста
Как сделать эту задачку
Только у меня не запятая а точка

[SAS888]

Попробуй так:

Sub Test()
    
    x = Val(InputBox("Number after comma", "Number 1"))
    y = Val(InputBox("Number icrement", "Number 2"))
    z = Selection.Column
    For i = Selection.Row To Selection.Row + Selection.Count - 1
        On Error Resume Next
        D = Application.Find(",", CStr(Cells(i, z)), 1) 'позиция запятой
        If D = "" Then GoTo Metka
        A = Mid(Cells(i, z), D + 1) 'дробная часть числа (в виде целого)
        B = Val(Application.Substitute(CStr(Cells(i, z)), ",", "")) 'убираем запятую
        If Val(Mid(A, x, 1)) > 3 Then B = CStr(B + 10 ^ y) '+1 к нужному разряду
        Cells(i, z) = B / 10 ^ Len(A) 'возвращаем запятую
        
Metka:    Next i

End Sub

Я здесь не стал вставлять проверку на введенные значения и на правильность выбранного диапазона. Но если нужно - можно сделать.

[SAS888]

Прошу прощенья, поторопился.
Следующий код исправлен и дополнен:

Sub Test()
    
    If Selection.Columns.Count > 1 Then
        MsgBox "Выделено более 1 столбца"
        Exit Sub
    End If
    x = Val(InputBox("Number after comma", "Number 1"))
    If x = 0 Then
        MsgBox "Недопустимое значение"
        Exit Sub
    End If
    y = Val(InputBox("Number increment", "Number 2"))
    If y > x Or y = 0 Then
        MsgBox "Недопустимое значение"
        Exit Sub
    End If
    
    z = Selection.Column
    For i = Selection.Row To Selection.Row + Selection.Count - 1
        On Error Resume Next
        D = Application.Find(",", CStr(Cells(i, z)), 1) 'позиция запятой
        If D = "" Then GoTo Metka
        A = Mid(Cells(i, z), D + 1) 'дробная часть числа (в виде целого)
        B = Val(Application.Substitute(CStr(Cells(i, z)), ",", "")) 'убираем запятую
        If Val(Mid(A, x, 1)) > 3 Then B = CStr(B + 10 ^ (Len(B) - (x - y + 1))) '+1 к нужному разряду
        Cells(i, z) = B / 10 ^ Len(A) 'возвращаем десятичную запятую
Metka: Next i
  
End Sub

Если я правильно понял, то ввод первого значения (здесь "x") - это номер цифры после запятой по которой контролируем < или > 3, а ввод второго значения (здесь "y") - это смещение влево, относительно "x" т. е. номер знака, который нужно модифицировать.
P.S. Макрос работает независимо от того, какой разделитель целой и дробной части числа установлен в Excel ("." или ",").

[SAS888]

А если руководствоваться заданию из Вашего файла, то код будет выглядеть примерно так:

Sub Test()
    
    If Selection.Columns.Count > 1 Then
        MsgBox "Выделено более 1 столбца"
        Exit Sub
    End If
    x = Val(InputBox("Number after comma", "Number 1"))
    If x = 0 Then
        MsgBox "Недопустимое значение"
        Exit Sub
    End If
    
    z = Selection.Column
    For i = Selection.Row To Selection.Row + Selection.Count - 1
        Cells(i, z) = Application.Round(Cells(i, z), 10)
        On Error Resume Next
        D = Application.Find(",", CStr(Cells(i, z)), 1) 'позиция запятой
        If D = "" Then GoTo Metka
        A = Mid(Cells(i, z), D + 1) 'дробная часть числа (в виде целого)
        B = Val(Application.Substitute(CStr(Cells(i, z)), ",", "")) 'убираем запятую
        If Val(Mid(A, x, 1)) > 3 Then B = CStr(B + 10 ^ (Len(A) - x + 1)) '+1 к нужному разряду
        Cells(i, z) = Fix((B / 10 ^ Len(A)) * 10 ^ (x - 1)) / 10 ^ (x - 1) 'возвращаем десятичную запятую
Metka: Next i
  
End Sub

Вводим только один параметр (номер знака после запятой), и предыдущий знак модифицируем с последующим соответствующим округлением числа.

[SAS888]

Улучшенная версия с подробными пояснениями находится в прикрепленном файле.
Я сделал так, что допустимо выбирать либо столбец целиком, либо диапазон ячеек в столбце. Если нужно иначе - можно воспользоваться циклом For Each Cell In Selection, т. е. для каждой ячейки выделенного диапазона.

[Romuald]

Пытаюсь запустить последнюю версию - ставлю любую цифру- никаких изменений. Просто странно

(у меня EXCEl 2003)

[SAS888]

Макрос сделан в Excel 2003.
Давайте уточним последовательность действий.
Пусть дан столбец с действительными числами (например, столбец "C" в моем файле).
1) Выделяем диапазон ячеек в столбце (или весь столбец).
2) При выделенном диапазоне запускаем макрос "Test" (при этом активный лист должен быть тот, где находится выделенный диапазон).
3) При запросе макросом значения "Number after comma", вводим число < или = количеству знаков после запятой. Это и будет тот знак, который будем сравнивать с числом 3.
После работы макроса получим измененный результат в выделенном диапазоне. Специально скачал именно этот файл и еще раз проверил.
Если все так, то скорее всего дело в следующем: макрос ничего не изменит в том случае, если в значениях не найдет разделителя целой и дробной части чисел. У меня ищется запятая. Установка Excel "Сервис/Параметры/Международные/Разделитель целой и дробной части" влияет только на отображение разделителя ( при любой установке, точка или запятая, все работает корректно). Как вариант, попробуйте заменить строку кода макроса D = Application.Find(",", CStr(Cells(i, z)), 1) на D = Application.Find(".", CStr(Cells(i, z)), 1)