Excel NormalizeSelectedCells

gistfile1.txt

Sub NormalizeSelectedCells()
    Dim rng As Range
    Dim cell As Range
    Dim multiple As Double
    Dim response As String
    Dim normalizedValue As Double
    Dim originalSign As Integer
    
    ' Проверяем, есть ли выделенные ячейки
    If Selection.Count = 0 Then
        MsgBox "Пожалуйста, выделите ячейки для нормализации", vbExclamation
        Exit Sub
    End If
    
    ' Запрашиваем кратное значение у пользователя
    response = InputBox("Введите кратное значение для нормализации:", "Нормализация чисел", "500")
    
    ' Проверяем, нажал ли пользователь Отмена
    If response = "" Then
        Exit Sub
    End If
    
    ' Проверяем, является ли введенное значение числом и больше 0
    If Not IsNumeric(response) Then
        MsgBox "Пожалуйста, введите числовое значение", vbCritical
        Exit Sub
    End If
    
    multiple = CDbl(response)
    
    If multiple <= 0 Then
        MsgBox "Кратное значение должно быть больше 0", vbCritical
        Exit Sub
    End If
    
    ' Устанавливаем диапазон для обработки
    Set rng = Selection
    
    ' Отключаем обновление экрана для повышения производительности
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' Обрабатываем каждую ячейку в выделении
    For Each cell In rng
        If Not IsError(cell.Value) Then
            If IsNumeric(cell.Value) Then
                ' Сохраняем знак исходного числа
                If cell.Value < 0 Then
                    originalSign = -1
                ElseIf cell.Value > 0 Then
                    originalSign = 1
                Else
                    originalSign = 0
                End If
                
                ' Вычисляем нормализованное значение
                normalizedValue = WorksheetFunction.Round(Abs(cell.Value) / multiple, 0) * multiple
                
                ' Восстанавливаем знак и записываем значение
                cell.Value = normalizedValue * originalSign
            End If
        End If
    Next cell
    
    ' Восстанавливаем настройки
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    ' Сообщаем о завершении
    MsgBox "Обработано " & rng.Count & " ячеек" & vbCrLf & _
           "Числа нормализованы к кратному: " & multiple, vbInformation
End Sub

' Функция для использования в ячейках Excel (опционально)
Function NormalizeToMultiple(ByVal number As Double, Optional ByVal multiple As Double = 500) As Double
    ' Округляет число до ближайшего кратного указанному значению с сохранением знака
    If multiple <= 0 Then
        NormalizeToMultiple = number
        Exit Function
    End If
    
    Dim originalSign As Integer
    If number < 0 Then
        originalSign = -1
    ElseIf number > 0 Then
        originalSign = 1
    Else
        originalSign = 0
    End If
    
    NormalizeToMultiple = WorksheetFunction.Round(Abs(number) / multiple, 0) * multiple * originalSign
End Function