Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Проставить процент макросом - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Проставить процент макросом (Макросы/Sub)
Проставить процент макросом
ekut Дата: Воскресенье, 27.12.2020, 10:24 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Уважаемы программисты!!! Как мне сделать, чтобы при проставлении слова "продлить" и числа в столбец F ( данные их столбцов L и M) в столбце G прописывался процент! А при слове списать сразу ставил 75%. Списать красным, продлить синим! Сейчас там есть макрос, но немного не то, что мне надо!!!! Благодарю заранее!!!!!
К сообщению приложен файл: 0005225-1-.xlsm(40.4 Kb)
 
Ответить
СообщениеУважаемы программисты!!! Как мне сделать, чтобы при проставлении слова "продлить" и числа в столбец F ( данные их столбцов L и M) в столбце G прописывался процент! А при слове списать сразу ставил 75%. Списать красным, продлить синим! Сейчас там есть макрос, но немного не то, что мне надо!!!! Благодарю заранее!!!!!

Автор - ekut
Дата добавления - 27.12.2020 в 10:24
Kuzmich Дата: Воскресенье, 27.12.2020, 18:57 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 575
Репутация: 113 ±
Замечаний: 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]
 
Ответить
СообщениеПопробуйте так
[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]

Автор - Kuzmich
Дата добавления - 27.12.2020 в 18:57
ekut Дата: Воскресенье, 27.12.2020, 19:43 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - ekut
Дата добавления - 27.12.2020 в 19:43
Hugo Дата: Воскресенье, 27.12.2020, 19:51 | Сообщение № 4
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

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


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеПрежде чем выйти из макроса - нужно вернуть взад что взяли! :)

Автор - Hugo
Дата добавления - 27.12.2020 в 19:51
ekut Дата: Воскресенье, 27.12.2020, 19:54 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

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

Автор - ekut
Дата добавления - 27.12.2020 в 19:54
Hugo Дата: Воскресенье, 27.12.2020, 19:57 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3140
Репутация: 670 ±
Замечаний: 0% ±

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


excel@nxt.ru
webmoney: R418926282008 Z422237915069
 
Ответить
СообщениеApplication.EnableEvents = False - взяли
Application.EnableEvents = True - положили назад
А когда вышли после "списать" - не положили!
Но это конечно косяк Кузмича...

Автор - Hugo
Дата добавления - 27.12.2020 в 19:57
Kuzmich Дата: Воскресенье, 27.12.2020, 19:59 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 575
Репутация: 113 ±
Замечаний: 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]
 
Ответить
СообщениеВот так переделал
[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]

Автор - Kuzmich
Дата добавления - 27.12.2020 в 19:59
ekut Дата: Воскресенье, 27.12.2020, 20:06 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 123
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Гениальненько!!!!!!!!Благодарююююююююю
 
Ответить
СообщениеГениальненько!!!!!!!!Благодарююююююююю

Автор - ekut
Дата добавления - 27.12.2020 в 20:06
bmv98rus Дата: Понедельник, 28.12.2020, 00:02 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3413
Репутация: 594 ±
Замечаний: 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]


Замечательный Временно просто медведь , процентов на 20.
 
Ответить
СообщениеЧуток косметики
[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]

Автор - bmv98rus
Дата добавления - 28.12.2020 в 00:02
RAN Дата: Понедельник, 28.12.2020, 10:24 | Сообщение № 10
Группа: Друзья
Ранг: Участник клуба
Сообщений: 5413
Репутация: 1082 ±
Замечаний: 0% ±

2010
bmv98rus, Миш, а почему индоутку не вставил?
Она как раз под этот файл.


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщениеbmv98rus, Миш, а почему индоутку не вставил?
Она как раз под этот файл.

Автор - RAN
Дата добавления - 28.12.2020 в 10:24
bmv98rus Дата: Понедельник, 28.12.2020, 10:56 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3413
Репутация: 594 ±
Замечаний: 0% ±

Excel 2013/2016
RAN, так только косметику правил, логику не трогал , ну разве что добавил обработку на случай копи пэста нескольких значений. :D . Тыж знаешь, не люблю я VBA :D


Замечательный Временно просто медведь , процентов на 20.
 
Ответить
СообщениеRAN, так только косметику правил, логику не трогал , ну разве что добавил обработку на случай копи пэста нескольких значений. :D . Тыж знаешь, не люблю я VBA :D

Автор - bmv98rus
Дата добавления - 28.12.2020 в 10:56
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Проставить процент макросом (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования Jobsora jooble
© 2010-2021 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!