Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
VBA. Сделать числа отрицательными (в зависимости от условия в соседнем столбце)
 
#1
30.12.2020 16:38:25
Доброго времени, суток, уважаемые гуру Excel.
Возник такой вопрос: как с помощью макроса в VBA сделать отрицательными числа в столбце B в зависимости от условия в той же строка но в столбце A
Пример прилагаю.
 
 
 
#2
30.12.2020 16:43:12
Цитата
Starik19 написал:
от условия в той же строка но в столбце A
И что это за условие?
Если в мире всё бессмысленно, — сказала Алиса, — что мешает выдумать какой-нибудь смысл? ©Льюис Кэрролл
 
 
 
#3
30.12.2020 16:44:20
В примере, если в столбце А стоит 262 то в той же строке столбца B сделать число отрицательным.

Я использую следующий код, но это, мне кажется, очень не верно и коряво и работает очень долго. Код макроса из рабочего документа, соответственно столбцы другие, но суть та же:
Код
Sub Сделать_отр()
' Сделать_отр Макрос
'

'
    Columns("R:R").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'вставляет столбец
    Range("R3").Select 'переходит в ячейку R3
    ActiveCell.FormulaR1C1 = "=IF(RC[-6]*1=261,RC[-1],ABS(RC[-1])*-1)" 'прописывает в ячейке R3 формулу
    Range("R3").Select 'выделяет ячейку R3
    Selection.AutoFill Destination:=Range("R3:R20000") 'протягивает формулу вниз до 20000 строки
    Range("R3:R20000").Select 'выделяет диапазон R3:R26270
    Selection.Copy 'копирует выделенное
    Range("Q3").Select 'выделяет ячейку Q3
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False 'вставляет выделенное в качестве значений
    Columns("R:R").Select 'выделяет весь столбец R
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft 'удаляет выделенный столбец
End Sub
Изменено: Starik19 - 30.12.2020 16:49:18
 
 
 
#4
30.12.2020 16:48:06
Как вариант:
1) Отфильтровали что нужно
2) Спецвставкой умонжили на -1
3) Сняли фильтр
У меня заняло 13 секунд
Если в мире всё бессмысленно, — сказала Алиса, — что мешает выдумать какой-нибудь смысл? ©Льюис Кэрролл
 
 
 
#5
30.12.2020 16:51:02
Это да, но этот кусок макроса является только частью общего макроса, который открывает документ и забирает из него данные. В исходном документе все данные с положительными значениями. Хотелось бы чтобы весь макрос выполнялся автоматически.
Если есть необходимость ниже приведу рабочий макрос целиком:
Код
Sub Input_COOIS_сделать_отр()
Application.ScreenUpdating = False 'отключаем обновление экрана (отображение изменений)
Application.Calculation = xlCalculationManual 'отключаем автоматический пересчет формул
Application.EnableEvents = False 'отключаем события
Call Данные_из_COOIS 'запускаем макрос Данные_из_COOIS
Application.Calculation = xlCalculationAutomatic 'включаем автоматический пересчет формул
Call Сделать_отр 'заупускаем макрос Сделать_отр
Application.ScreenUpdating = True 'включаем обновление экрана (отображенеие изменений)
Application.EnableEvents = True 'включаем события
End Sub
Соответственно Данные_из_COOIS:
Код
Sub Данные_из_COOIS()
'Шаг 1: Определяем переменную.
Dim FName As Variant
Dim bookconst As Workbook
Dim abook As Workbook
Set abook = ActiveWorkbook
'Шаг 2: Метод GetOpenFilename активизирует диалоговое окно.
FName = Application.GetOpenFilename
'a – определяем тип файла
FileFilter = "Excel Workbooks,*.xl*"
'b – заголовок окна
Title = "Выбери файл, который надо открыть"
'c – множественный выбор
MultiSelect = False
'Шаг 3: Если был выбран файл, открыть его!
If FName <> False Then
Workbooks.Open Filename:=FName
'Range("A2:B15000").Copy 'Выделяем область и копируем (первые два столбца)
Range("A2:B2").Select
Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Activate 'Переходим в рабочую книгу из котрой запускали макрос
Sheets("CRT INPUT").Select 'Выбираем лист "CRT INPUT"
Range("A3").PasteSpecial Paste:=xlPasteValues 'Выбираем ячейку, Вставляем скопированные данные через специальныю вставку значениями, чтобы не сломаились формулы
Workbooks.Open Filename:=FName
'Range("C2:P15000").Copy 'Выделяем область и копируем (с material и дальше)
Range("C2:P2").Select
Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Activate
Sheets("CRT INPUT").Select 'Выбираем лист "CRT INPUT"
Range("E3").PasteSpecial Paste:=xlPasteValues 'Выбираем ячейку, Вставляем скопированные данные через специальныю вставку значениями, чтобы не сломаились формулы
End If

End Sub
И Сделать_отр:
Код
Sub Сделать_отр()
'
' Сделать_отр Макрос
'

'
    Columns("R:R").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove 'вставляет столбец
    Range("R3").Select 'переходит в ячейку R3
    ActiveCell.FormulaR1C1 = "=IF(RC[-6]*1=261,RC[-1],ABS(RC[-1])*-1)" 'прописывает в ячейке R3 формулу
    Range("R3").Select 'выделяет ячейку R3
    Selection.AutoFill Destination:=Range("R3:R20000") 'протягивает формулу вниз до 20000 строки
    Range("R3:R20000").Select 'выделяет диапазон R3:R26270
    Selection.Copy 'копирует выделенное
    Range("Q3").Select 'выделяет ячейку Q3
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False 'вставляет выделенное в качестве значений
    Columns("R:R").Select 'выделяет весь столбец R
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft 'удаляет выделенный столбец
End Sub

Вот, если есть замечания и рекомендации по ускорению работы всего этого с радостью выслушаю.
Изменено: Starik19 - 30.12.2020 16:54:42
 
 
 
#6
30.12.2020 16:53:21
Код
For i=3 To Cells(Rows.Count,1).End(xlUp).Row
    If Cells(i,1)>=262 Then Cells(i,2)=Cells(i,2)*(-1)
next

8000 строк для примера многовато, да и еще то что хотели показать в самом конце. 80% даже туда не долистает.
 
 
 
#7
30.12.2020 16:57:46
Прошу, прощения, сократил. В первом сообщении прикрепил новый файл, тут продублировал на всякий случай
 
 
 
#8
30.12.2020 17:10:15
V, спасибо большое.
Можно не большое уточнение?
Так как рабочий файл весьма тяжелый и выполнение вашего макроса занимает очень много времени, можно безболезненно отключить автоматический пересчет с помощью:
Код
Application.Calculation = xlCalculationManual

For i=3 To Cells(Rows.Count,1).End(xlUp).Row

    If Cells(i,1)>=262 Then Cells(i,2)=Cells(i,2)*(-1)

next

Application.Calculation = xlCalculationAutomatic
Изменено: Starik19 - 30.12.2020 17:10:42
 
 
 
#9
30.12.2020 22:00:32
При необходимости, можно сразу  весь диапазон умножить на число, не используя цикла.
Код
Range("A1:A10").Formula = Application.Evaluate("=" & Range("A1:A10").Address(0, 0) & "*" & -1)'
'или
Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Formula = Application.Evaluate("=" & Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row).Address(0, 0) & "*" & -1)
Изменено: DANIKOLA - 31.12.2020 09:42:20
 
 
 
#10
30.12.2020 22:30:06
Starik19, вариант
Код
Sub mrshkei()
Dim arr, arr2, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row: arr = Range("A3:B" & lr): ReDim arr2(1 To lr, 1 To 2)
For i = LBound(arr) To UBound(arr)
    If arr(i, 1) >= 262 Then
        arr2(i, 1) = arr(i, 1): arr2(i, 2) = arr(i, 2) * (-1)
    Else
        arr2(i, 1) = arr(i, 1): arr2(i, 2) = arr(i, 2)
    End If
Next i
Range("F3").Resize(UBound(arr2), 2) = arr2
End Sub
Не бойтесь совершенства. Вам его не достичь.
 
 
 
#11
31.12.2020 10:13:25
Код
Sub qq()
    Dim ar, i&
    ar = Range(Cells(3, 2), Cells(Rows.Count, 1).End(xlUp)).Value
    For i = 1 To UBound(ar)
        ar(i, 1) = ar(i, 2) * ((ar(i, 1) = 262) - (ar(i, 1) <> 262))
    Next
    Cells(3, 2).Resize(UBound(ar)) = ar
End Sub
 
 
 
#12
01.01.2021 14:01:58
RAN, добрый день и с наступившим новым годом. К сожалению я ни как не могу разобраться в логике кода. Можете пояснить? Я пытаюсь приспособить его к рабочему фалу (отличается количество и порядок столбцов).
 
 
 
#13
01.01.2021 16:02:45
Берем в массив 2 столбца
Бежим по массиву, меняя значения 1 столбца массива на значения второго,  попутно умножая их на плюс или минус единицу, в зависимости от условия (* ((ar(i, 1) = 262) - (ar(i, 1) <> 262)))
Выгружаем массив во второй столбец
 
 
 
Страницы: 1
Наверх