Проставить процент макросом

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Проставить процент макросом (Макросы/Sub)

ekut

Дата: Воскресенье, 27.12.2020, 10:24 | Сообщение № 1

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 195

Репутация: 3 ±

Замечаний: 0% ±

Excel 2007

Уважаемы программисты!!! Как мне сделать, чтобы при проставлении слова "продлить" и числа в столбец F ( данные их столбцов L и M) в столбце G прописывался процент! А при слове списать сразу ставил 75%. Списать красным, продлить синим! Сейчас там есть макрос, но немного не то, что мне надо!!!! Благодарю заранее!!!!!

К сообщению приложен файл: 0005225-1-.xlsm (40.4 Kb)

Ответить

Kuzmich

Дата: Воскресенье, 27.12.2020, 18:57 | Сообщение № 2

Группа: Проверенные

Ранг: Ветеран

Сообщений: 712

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

Попробуйте так
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("E:F")) Is Nothing Then
Dim FoundCell As Range
Application.EnableEvents = False
If Target.Column = 5 And Target = "списать" Then
    Target.Offset(, 2) = "75%"
    Exit Sub
Else
   If Target.Column = 6 And Target.Offset(, -1) = "продлить" Then
     Set FoundCell = Columns("L").Find(Target, , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       Target.Offset(, 1) = FoundCell.Offset(, 1)
     Else
        MsgBox "В столбце L нет значения: " & Target
        Target.Offset(, 1) = ""
     End If
   End If
End If
Application.EnableEvents = True
    End If
End Sub

[/vba]

Ответить

ekut

Дата: Воскресенье, 27.12.2020, 19:43 | Сообщение № 3

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 195

Репутация: 3 ±

Замечаний: 0% ±

Excel 2007

Kuzmich, здравствуйте! У меня работает только первая строка! Ставлю списать, выходит 75%, в ней же ставлю продлить,,,, и ничего

Ответить

Hugo

Дата: Воскресенье, 27.12.2020, 19:51 | Сообщение № 4

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3255

Репутация: 707 ±

Замечаний: 0% ±

2019

Прежде чем выйти из макроса - нужно вернуть взад что взяли!

excel@nxt.ru
webmoney: E265281470651 Z422237915069

Ответить

ekut

Дата: Воскресенье, 27.12.2020, 19:54 | Сообщение № 5

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 195

Репутация: 3 ±

Замечаний: 0% ±

Excel 2007

И Вам здравствуйте!!!!!! "Прежде чем выйти из макроса - нужно вернуть взад что взяли!" это как и что???

Ответить

Hugo

Дата: Воскресенье, 27.12.2020, 19:57 | Сообщение № 6

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3255

Репутация: 707 ±

Замечаний: 0% ±

2019

Application.EnableEvents = False - взяли
Application.EnableEvents = True - положили назад
А когда вышли после "списать" - не положили!
Но это конечно косяк Кузмича...

excel@nxt.ru
webmoney: E265281470651 Z422237915069

Ответить

Kuzmich

Дата: Воскресенье, 27.12.2020, 19:59 | Сообщение № 7

Группа: Проверенные

Ранг: Ветеран

Сообщений: 712

Репутация: 156 ±

Замечаний: 0% ±

Excel 2003

Вот так переделал
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E:E")) Is Nothing Then
     Application.EnableEvents = False
Dim FoundCell As Range
  If Target = "списать" Then
     Target.Offset(, 1) = ""
     Target.Offset(, 2) = "75%"
     Target.Font.ColorIndex = 3
     Target.Offset(, 2).Font.ColorIndex = 3
     Application.EnableEvents = True
     Exit Sub
  Else
    If Target = "продлить" Then
       Target.Offset(, 1) = Application.InputBox("Введите количество", Type:=1)
       Set FoundCell = Columns("L").Find(Target.Offset(, 1), , xlValues, xlWhole)
     If Not FoundCell Is Nothing Then
       Target.Offset(, 2) = FoundCell.Offset(, 1)
       Target.Font.ColorIndex = 5
       Target.Offset(, 1).Font.ColorIndex = 5
       Target.Offset(, 2).Font.ColorIndex = 5
     Else
        MsgBox "В столбце L нет значения: " & Target.Offset(, 1)
        Target.Offset(, 1) = ""
        Target.Offset(, 2) = ""
     End If
    End If
  End If
End If
    Application.EnableEvents = True
End Sub

[/vba]

Ответить

ekut

Дата: Воскресенье, 27.12.2020, 20:06 | Сообщение № 8

Группа: Проверенные

Ранг: Форумчанин

Сообщений: 195

Репутация: 3 ±

Замечаний: 0% ±

Excel 2007

Гениальненько!!!!!!!!Благодарююююююююю

Ответить

bmv98rus

Дата: Понедельник, 28.12.2020, 00:02 | Сообщение № 9

Группа: Друзья

Ранг: Участник клуба

Сообщений: 4110

Репутация: 768 ±

Замечаний: 0% ±

Excel 2013/2016

Чуток косметики
[vba]

Код

Private Sub Worksheet_Change(ByVal Target As Range)
Dim FoundCell As Range, Cell As Range
If Not Intersect(Target, Range("E:E")) Is Nothing Then
    Application.EnableEvents = False
    For Each Cell In Intersect(Target, Range("E:E"))
        With Cell
            If .Value = "списать" Then
                .Offset(, 1) = ""
                .Offset(, 2) = "75%"
                .Font.ColorIndex = 3
                .Offset(, 2).Font.ColorIndex = 3
            ElseIf .Value = "продлить" Then
                .Offset(, 1) = Application.InputBox("Введите количество", Type:=1)
                Set FoundCell = Columns("L").Find(.Offset(, 1), , xlValues, xlWhole)
                If Not FoundCell Is Nothing Then
                    .Offset(, 2) = FoundCell.Offset(, 1)
                    .Resize(, 3).Font.ColorIndex = 5
                 Else
                MsgBox "В столбце L нет значения: " & .Offset(, 1)
                .Offset(, 1).Resize(, 2) = ""
                End If
            End If
        End With
    Next
    Application.EnableEvents = True
End If
End Sub

[/vba]