Option Explicit

Sub CalculateProductFromFormattedString()

    ' --- Константы ---
    ' Имя листа, на котором находится столбец с данными
    Const TargetSheetName As String = "Лист1" ' <--- ИЗМЕНИТЕ НА ИМЯ ВАШЕГО ЛИСТА (например, "Данные")

    ' Диапазон ячеек с исходными данными (столбец, например, "A1:A10" или "B2:B100")
    Const DataRangeAddress As String = "A1:A10" ' <--- ИЗМЕНИТЕ НА НУЖНЫЙ ДИАПАЗОН С ВАШИМИ ДАННЫМИ

    ' Диапазон ячеек для записи результатов (произведения).
    ' Может быть тот же столбец, если вы хотите заменить исходные данные результатом,
    ' или другой столбец (например, "B1:B10"), куда будут записаны результаты.
    ' Убедитесь, что размер и количество ячеек в диапазоне результатов соответствует диапазону данных.
    Const ResultRangeAddress As String = "B1:B10" ' <--- ИЗМЕНИТЕ НА ДИАПАЗОН ДЛЯ ЗАПИСИ РЕЗУЛЬТАТОВ

    ' --- Переменные ---
    Dim ws As Worksheet          ' Объект листа Excel
    Dim dataRng As Range         ' Объект диапазона с исходными данными
    Dim resultRng As Range       ' Объект диапазона для записи результатов
    Dim dataCell As Range        ' Объект для перебора каждой ячейки в диапазоне данных
    Dim resultCell As Range      ' Объект для записи результата в соответствующую ячейку
    Dim cellValue As Variant     ' Значение, прочитанное из ячейки (может быть пустым)
    Dim cellText As String       ' Значение ячейки как строка для обработки
    Dim cleanedText As String    ' Строка после удаления лишних символов (" д")
    Dim numbersArray() As String ' Массив строк с числами после разделения
    Dim product As Double        ' Переменная для хранения произведения чисел
    Dim numStr As Variant        ' Переменная для перебора элементов массива чисел (как строк)
    Dim numValue As Double       ' Переменная для хранения числового значения после преобразования
    Dim i As Long                ' Счетчик для синхронизации ячеек в диапазонах данных и результатов

    ' --- Настройка ---
    ' Включаем обработку ошибок. Если произойдет ошибка, выполнение перейдет к метке ErrorHandler.
    On Error GoTo ErrorHandler
    ' Отключаем обновление экрана для ускорения работы макроса на больших диапазонах.
    Application.ScreenUpdating = False
    ' Возможно, потребуется отключить автоматический пересчет, если у вас много формул.
    ' Application.Calculation = xlCalculationManual

    ' --- Получение объектов листа и диапазонов ---
    ' Временно отключаем обработку ошибок, чтобы проверить существование листа и диапазонов
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets(TargetSheetName)
    Set dataRng = ws.Range(DataRangeAddress)
    Set resultRng = ws.Range(ResultRangeAddress) ' Получаем диапазон для результатов

    ' Восстанавливаем стандартную обработку ошибок
    On Error GoTo ErrorHandler

    ' Проверяем, найдены ли лист и диапазоны
    If ws Is Nothing Then
        MsgBox "Ошибка: Лист с именем """ & TargetSheetName & """ не найден.", vbCritical
        GoTo ExitMacro
    End If

    If dataRng Is Nothing Then
        MsgBox "Ошибка: Некорректный адрес диапазона данных """ & DataRangeAddress & """ на листе """ & TargetSheetName & """.", vbCritical
        GoTo ExitMacro
    End If

    If resultRng Is Nothing Then
        MsgBox "Ошибка: Некорректный адрес диапазона результатов """ & ResultRangeAddress & """ на листе """ & TargetSheetName & """.", vbCritical
        GoTo ExitMacro
    End If

    ' Проверяем, что количество ячеек в диапазонах данных и результатов совпадает
    If dataRng.Cells.Count <> resultRng.Cells.Count Then
         MsgBox "Ошибка: Количество ячеек в диапазоне данных (" & dataRng.Address(False, False) & ") " & _
                "и диапазоне результатов (" & resultRng.Address(False, False) & ") не совпадает." & vbCrLf & _
                "Эти диапазоны должны иметь одинаковый размер (например, A1:A10 и B1:B10, или A1:A10 и A1:A10).", vbCritical
         GoTo ExitMacro
    End If


    ' --- Обработка каждой ячейки в диапазоне данных ---
    i = 1 ' Инициализируем счетчик для доступа к соответствующей ячейке в диапазоне результатов

    For Each dataCell In dataRng.Cells
        ' Определяем соответствующую ячейку в диапазоне результатов
        Set resultCell = resultRng.Cells(i)

        ' Читаем значение из текущей ячейки данных
        cellValue = dataCell.Value

        ' Проверяем, пуста ли ячейка или содержит ошибку
        If IsEmpty(cellValue) Or IsError(cellValue) Then
            resultCell.Value = cellValue ' Копируем пустоту или ошибку в ячейку результата
            i = i + 1
            GoTo NextCell ' Переходим к следующей ячейке данных
        End If

        ' Преобразуем значение в текст и убираем лишние пробелы по краям
        cellText = Trim(CStr(cellValue))

        ' Проверяем, не стала ли строка пустой после Trim
        If cellText = "" Then
            resultCell.Value = "" ' Если пустая строка, оставляем ячейку результата пустой
            i = i + 1
            GoTo NextCell
        End If

        ' --- Очистка строки от лишних символов ---
        ' Удаляем " д" (пробел + "д"). Важно удалить пробел перед "д".
        cleanedText = Replace(cellText, " д", "")
        ' Также удаляем просто "д", если вдруг нет пробела перед ней
        cleanedText = Replace(cleanedText, "д", "")
         ' Удаляем возможные лишние пробелы в начале или конце после удаления "д"
        cleanedText = Trim(cleanedText)

        ' --- Разделение строки на отдельные числа ---
        ' Разделяем очищенную строку на массив строк, используя " x " как разделитель.
        ' Split("1 x 2 x 3", " x ") вернет массив: {"1", "2", "3"}
        ' Split("4", " x ") вернет массив: {"4"}
        numbersArray = Split(cleanedText, " x ")

        ' --- Вычисление произведения ---
        product = 1 ' Инициализируем произведение единицей (чтобы первое число умножилось на 1)
        Dim conversionError As Boolean ' Флаг для отслеживания ошибок преобразования

        ' Перебираем каждую строку-число в полученном массиве
        For Each numStr In numbersArray
            ' Убираем лишние пробелы из текущей строки-числа
            numStr = Trim(CStr(numStr)) ' Убедимся, что это строка перед Trim

            ' Проверяем, не пустая ли строка после Trim (может быть при двойном разделителе " x x ")
            If numStr <> "" Then
                ' Пытаемся преобразовать строку в число (Double для поддержки десятичных)
                On Error Resume Next ' Временно игнорируем ошибку при преобразовании в число
                numValue = CDbl(numStr)
                On Error GoTo ErrorHandler ' Восстанавливаем стандартную обработку ошибок

                ' Проверяем, была ли ошибка преобразования (например, если в строке не число)
                If Err.Number <> 0 Then
                    ' Если произошла ошибка при преобразовании, помечаем флаг и выходим из внутреннего цикла
                    conversionError = True
                    Exit For
                End If

                ' Умножаем текущее число на текущее произведение
                product = product * numValue
            End If
        Next numStr ' Переходим к следующему элементу в массиве чисел

        ' --- Запись результата ---
        ' Проверяем, не было ли ошибок при преобразовании чисел
        If conversionError Then
            ' Если была ошибка преобразования, записываем сообщение об ошибке в ячейку результата
            resultCell.Value = "Ошибка данных: " & cleanedText
        Else
             ' Если ошибок не было, записываем вычисленное произведение
            resultCell.Value = product
        End If


NextCell: ' Метка для перехода к следующей ячейке данных в цикле For Each
        i = i + 1 ' Увеличиваем счетчик ячеек
    Next dataCell ' Переходим к следующей ячейке в диапазоне данных

    ' --- Сообщение об успешном завершении ---
    MsgBox "Расчеты завершены.", vbInformation

ExitMacro:
    ' --- Секция завершения макроса (выполняется всегда при выходе, включая ошибки) ---
    ' Включаем обратно обновление экрана
    Application.ScreenUpdating = True

    ' Если отключали автоматический пересчет, включаем его обратно
    ' If Application.Calculation = xlCalculationManual Then Application.Calculation = xlCalculationAutomatic

    ' Очищаем используемые объекты
    Set ws = Nothing
    Set dataRng = Nothing
    Set resultRng = Nothing
    Set dataCell = Nothing
    Set resultCell = Nothing

    Exit Sub ' Завершаем выполнение макроса

ErrorHandler:
    ' --- Обработчик ошибок ---
    ' Если произошла непредвиденная ошибка
    MsgBox "Произошла ошибка № " & Err.Number & ": " & Err.Description & vbCrLf & _
           "Макрос будет завершен." & vbCrLf & _
           "При обработке ячейки: " & dataCell.Address(False, False) & vbCrLf & _
           "Исходное значение: """ & cellValue & """", vbCritical
    Resume ExitMacro ' Переходим к секции завершения для корректного выхода
End Sub