Доброго времени суток! Делаю макрос, в котором надо к числовым значениям ячеек прибавить некоторое число. Таблица со значениями генерируется сторонней программой и все значения в текстовом виде, однако у некоторых значений имеется у числа звездочка "*", например 1677.25*. При этом после вычислений эту звездочку надо вернуть на место. Но что только не делал, но избавиться от звездочки в числе не получается. Пробовал и символами играть "~*", Chr(42), и Left+Len и Replace не хочет работать и все. Помогите с этой звездочкой. П.С. ИИ тоже не помог. [vba]
Код
Sub Summa2() Dim LastRowList, LastRowObr As Long, List, zvezda, TempCell As String Dim Cell As Range Dim add, CellVal As Double With Sheets("обработка") List = Str(.Cells(1, 2)) LastRowObr = .Cells(.Rows.Count, "A").End(xlUp).Row End With
With Sheets(List) LastRowList = .Cells(.Rows.Count, "A").End(xlUp).Row .Range(.Cells(2, 3), .Cells(LastRowList, 10)).Replace What:=".", replacement:=",", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False End With For i = 5 To LastRowObr add = val(Sheets("обработка").Cells(i, "C").Value) / 1000
For j = 2 To LastRowList If CStr(Sheets(List).Cells(j, "B").Value) = CStr(Sheets("обработка").Cells(i, "A").Value) Then
For k = 3 To 10 Set Cell = Sheets(List).Cells(j, k) zvezda = ""
'начало проблемного места If Len(Trim(Cell.text)) = 0 Or Cell.Value = "*" Then GoTo 2 Else GoTo 1 1: If CStr(Cell.Value) Like "\*" Then zvezda = "*": _ Cell.Value = Replace(Cell.Value, Chr(42), "") _ Else: zvezda = "" CellVal = CDbl(Cell.Value) 'конец проблемного места CellVal = CellVal + add Cell = CellVal & zvezda Cell = Format(Cell.Value, "0.00") 2: Next k End If Next j Next i
End Sub
[/vba]
Доброго времени суток! Делаю макрос, в котором надо к числовым значениям ячеек прибавить некоторое число. Таблица со значениями генерируется сторонней программой и все значения в текстовом виде, однако у некоторых значений имеется у числа звездочка "*", например 1677.25*. При этом после вычислений эту звездочку надо вернуть на место. Но что только не делал, но избавиться от звездочки в числе не получается. Пробовал и символами играть "~*", Chr(42), и Left+Len и Replace не хочет работать и все. Помогите с этой звездочкой. П.С. ИИ тоже не помог. [vba]
Код
Sub Summa2() Dim LastRowList, LastRowObr As Long, List, zvezda, TempCell As String Dim Cell As Range Dim add, CellVal As Double With Sheets("обработка") List = Str(.Cells(1, 2)) LastRowObr = .Cells(.Rows.Count, "A").End(xlUp).Row End With
With Sheets(List) LastRowList = .Cells(.Rows.Count, "A").End(xlUp).Row .Range(.Cells(2, 3), .Cells(LastRowList, 10)).Replace What:=".", replacement:=",", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False End With For i = 5 To LastRowObr add = val(Sheets("обработка").Cells(i, "C").Value) / 1000
For j = 2 To LastRowList If CStr(Sheets(List).Cells(j, "B").Value) = CStr(Sheets("обработка").Cells(i, "A").Value) Then
For k = 3 To 10 Set Cell = Sheets(List).Cells(j, k) zvezda = ""
'начало проблемного места If Len(Trim(Cell.text)) = 0 Or Cell.Value = "*" Then GoTo 2 Else GoTo 1 1: If CStr(Cell.Value) Like "\*" Then zvezda = "*": _ Cell.Value = Replace(Cell.Value, Chr(42), "") _ Else: zvezda = "" CellVal = CDbl(Cell.Value) 'конец проблемного места CellVal = CellVal + add Cell = CellVal & zvezda Cell = Format(Cell.Value, "0.00") 2: Next k End If Next j Next i
Hugo, был бы любой другой символ - это работало, но именно со звездочкой какой-то треш. При stop смотрю значения, а звездочка как была, так и остается, соответственно потом улетает в ошибку типа данных.
Hugo, был бы любой другой символ - это работало, но именно со звездочкой какой-то треш. При stop смотрю значения, а звездочка как была, так и остается, соответственно потом улетает в ошибку типа данных.Паштет
Паштет, Вобщем долго я не мог понять логику вашего кода. А именно данного блока кода:[vba]
Код
If CStr(Cell.Value) Like "\*" Then zvezda = "*": _ Cell.Value = Replace(Cell.Value, Chr(42), "") _ Else: zvezda = ""
[/vba] и решил пойти чкть другим путём:[vba]
Код
' Сохраняем адресс ячейки, если есть * для того чтоб её после вернуть обратно If Right(Cell.Text, 1) = "*" Then starCells(Cell.Address) = True Cell.Value = Replace(Cell.Value, "*", "") End If
[/vba]Ну и в конечном результате вот такой код:[vba]
Код
Sub Summa2() Dim i As Long, j As Long, k As Long Dim Cell As Range Dim CellVal As Double Dim Key As Variant
Dim starCells As Object Set starCells = CreateObject("Scripting.Dictionary") ' Для хранения адресов с *
With ThisWorkbook.Worksheets("обработка")
Dim List As String List = CStr(.Cells(1, 2).Value)
Dim LastRowObr As Long LastRowObr = .Cells(.Rows.Count, "A").End(xlUp).Row End With
With ThisWorkbook.Worksheets(List)
Dim LastRowList As Long LastRowList = .Cells(.Rows.Count, "B").End(xlUp).Row .Range(.Cells(2, 3), .Cells(LastRowList, 10)).Replace What:=".", replacement:=",", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False End With
For i = 5 To LastRowObr
Dim add As Double add = val(ThisWorkbook.Worksheets("обработка").Cells(i, "C").Value) / 1000
For j = 2 To LastRowList If CStr(ThisWorkbook.Worksheets(List).Cells(j, "B").Value) = CStr(Sheets("обработка").Cells(i, "A").Value) Then
For k = 3 To 10 Set Cell = ThisWorkbook.Worksheets(List).Cells(j, k)
If Len(Trim(Cell.Text)) = 0 Or Cell.Text = "*" Then GoTo SkipCell
' Сохраняем адресс ячейки, если есть * для того чтоб её после вернуть обратно If Right(Cell.Text, 1) = "*" Then starCells(Cell.Address) = True Cell.Value = Replace(Cell.Value, "*", "") End If
On Error Resume Next CellVal = CDbl(Cell.Value) On Error GoTo 0
' Возвращаем * обратно For Each Key In starCells.Keys ThisWorkbook.Worksheets(List).Range(Key).Value = ThisWorkbook.Worksheets(List).Range(Key).Value & "*" Next Key
Set starCells = Nothing End Sub
[/vba]Логику расчётов не менял так как не вникал в неё. Думаю это тот результат который вы ожидаете. Удачи.
Паштет, Вобщем долго я не мог понять логику вашего кода. А именно данного блока кода:[vba]
Код
If CStr(Cell.Value) Like "\*" Then zvezda = "*": _ Cell.Value = Replace(Cell.Value, Chr(42), "") _ Else: zvezda = ""
[/vba] и решил пойти чкть другим путём:[vba]
Код
' Сохраняем адресс ячейки, если есть * для того чтоб её после вернуть обратно If Right(Cell.Text, 1) = "*" Then starCells(Cell.Address) = True Cell.Value = Replace(Cell.Value, "*", "") End If
[/vba]Ну и в конечном результате вот такой код:[vba]
Код
Sub Summa2() Dim i As Long, j As Long, k As Long Dim Cell As Range Dim CellVal As Double Dim Key As Variant
Dim starCells As Object Set starCells = CreateObject("Scripting.Dictionary") ' Для хранения адресов с *
With ThisWorkbook.Worksheets("обработка")
Dim List As String List = CStr(.Cells(1, 2).Value)
Dim LastRowObr As Long LastRowObr = .Cells(.Rows.Count, "A").End(xlUp).Row End With
With ThisWorkbook.Worksheets(List)
Dim LastRowList As Long LastRowList = .Cells(.Rows.Count, "B").End(xlUp).Row .Range(.Cells(2, 3), .Cells(LastRowList, 10)).Replace What:=".", replacement:=",", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False End With
For i = 5 To LastRowObr
Dim add As Double add = val(ThisWorkbook.Worksheets("обработка").Cells(i, "C").Value) / 1000
For j = 2 To LastRowList If CStr(ThisWorkbook.Worksheets(List).Cells(j, "B").Value) = CStr(Sheets("обработка").Cells(i, "A").Value) Then
For k = 3 To 10 Set Cell = ThisWorkbook.Worksheets(List).Cells(j, k)
If Len(Trim(Cell.Text)) = 0 Or Cell.Text = "*" Then GoTo SkipCell
' Сохраняем адресс ячейки, если есть * для того чтоб её после вернуть обратно If Right(Cell.Text, 1) = "*" Then starCells(Cell.Address) = True Cell.Value = Replace(Cell.Value, "*", "") End If
On Error Resume Next CellVal = CDbl(Cell.Value) On Error GoTo 0
' Возвращаем * обратно For Each Key In starCells.Keys ThisWorkbook.Worksheets(List).Range(Key).Value = ThisWorkbook.Worksheets(List).Range(Key).Value & "*" Next Key
Set starCells = Nothing End Sub
[/vba]Логику расчётов не менял так как не вникал в неё. Думаю это тот результат который вы ожидаете. Удачи.MikeVol
Паштет, Вобщем долго я не мог понять логику вашего кода. А именно данного блока кода
Смысл в том, что если число написано со звездочкой, то убираем звездочку из числа, и присваиваем ее переменной zvezda, что бы после вычисления обратно добавить звезду к получившемуся числу. Чуть позже проверю ваш код.
Hugo, Pelena, при всем уважении, при первой обработке числа со звездой вылет ошибки в строке: [vba]
Код
CellVal = CDbl(Cell.Value)
[/vba].
Цитата
Паштет, Вобщем долго я не мог понять логику вашего кода. А именно данного блока кода
Смысл в том, что если число написано со звездочкой, то убираем звездочку из числа, и присваиваем ее переменной zvezda, что бы после вычисления обратно добавить звезду к получившемуся числу. Чуть позже проверю ваш код.
Hugo, Pelena, при всем уважении, при первой обработке числа со звездой вылет ошибки в строке: [vba]
при первой обработке числа со звездой вылет ошибки в строке:
- это другой вопрос, у нас очевидно не вылетает, у меня точно. Это уже региональные настройки, разделители. Можно конечно делать универсально или под конкретную систему... Но не было такой задачи. Тем более что это срабатывает когда никакой звёздочки в значении нет ))
при первой обработке числа со звездой вылет ошибки в строке:
- это другой вопрос, у нас очевидно не вылетает, у меня точно. Это уже региональные настройки, разделители. Можно конечно делать универсально или под конкретную систему... Но не было такой задачи. Тем более что это срабатывает когда никакой звёздочки в значении нет ))Hugo
Ну это не проблема, просто в ячейке может быть строка, которую можно преобразовать в число, а может быть то что нельзя. У меня отработало без ошибок, но я не изучал где ошибка у Вас, да Вы и не показали.
Ну это не проблема, просто в ячейке может быть строка, которую можно преобразовать в число, а может быть то что нельзя. У меня отработало без ошибок, но я не изучал где ошибка у Вас, да Вы и не показали.Hugo
А с чего вы взяли что должна произойти ошибка? Ошибка может произойти если значение в ячейке вообще не число (например, "abc" или "#DIV/0!", ошибка в вычеслиния формулы). CDbl выдаёт ошибку - подавляется ошибка и CellVal остаётся 0 и тогда в расчётах будет использоваться ноль, что может быть логически неверно. Вопрос возможно будет от вас следуйщий: Как CellVal остаётся 0? Всё потому что мы объявили Dim CellVal As Double, и значит по умолчанию равен 0 (ноль). Хотите можете так написать данный блок:[vba]
Код
' Проверка: можно ли безопасно конвертировать в число If IsNumeric(Cell.Value) Then CellVal = CDbl(Cell.Value) CellVal = CellVal + add Cell.Value = Format(CellVal, "0.00") End If
[/vba]Тут мы чётко проверяем, что значение действительно числовое, это явнее и безопаснее, чем полагаться на On Error Resume Next. А может я не понял ваш вопрос
А с чего вы взяли что должна произойти ошибка? Ошибка может произойти если значение в ячейке вообще не число (например, "abc" или "#DIV/0!", ошибка в вычеслиния формулы). CDbl выдаёт ошибку - подавляется ошибка и CellVal остаётся 0 и тогда в расчётах будет использоваться ноль, что может быть логически неверно. Вопрос возможно будет от вас следуйщий: Как CellVal остаётся 0? Всё потому что мы объявили Dim CellVal As Double, и значит по умолчанию равен 0 (ноль). Хотите можете так написать данный блок:[vba]
Код
' Проверка: можно ли безопасно конвертировать в число If IsNumeric(Cell.Value) Then CellVal = CDbl(Cell.Value) CellVal = CellVal + add Cell.Value = Format(CellVal, "0.00") End If
[/vba]Тут мы чётко проверяем, что значение действительно числовое, это явнее и безопаснее, чем полагаться на On Error Resume Next. А может я не понял ваш вопрос
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
