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

 

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

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир 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)
 
Ответить
СообщениеУважаемы программисты!!! Как мне сделать, чтобы при проставлении слова "продлить" и числа в столбец F ( данные их столбцов L и M) в столбце G прописывался процент! А при слове списать сразу ставил 75%. Списать красным, продлить синим! Сейчас там есть макрос, но немного не то, что мне надо!!!! Благодарю заранее!!!!!
Автор - ekut
Дата добавления - 27.12.2020 в 10:24
Kuzmich Дата: Воскресенье, 27.12.2020, 18:57 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 715
Репутация: 157 ±
Замечаний: 0% ±

Excel 2003
Попробуйте так

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]
Private Sub Worksheet_Change(ByVal Target As Range)    If Not Intersect(Target; Range("E:F")) Is Nothing ThenDim FoundCell As RangeApplication.EnableEvents = False If Target.Column = 5 And Target = "списать" Then    Тarget.Offset(; 2) = "75%"    Exit Sub Else   If Target.Column = 6 And Тarget.Offset(; -1) = "продлить" Then     Set FoundCell = Columns("L").Find(Target; ; xlValues; xlWhole)     If Not FoundCell Is Nothing Then       Тarget.Offset(; 1) = FoundCell.Offset(; 1)     Else        MsgBox "В столбце L нет значения: " & Target        Тarget.Offset(; 1) = ""     End If   End If End IfApplication.EnableEvents = Тrue    End IfEnd Sub
[/vba]
Автор - Kuzmich
Дата добавления - 27.12.2020 в 18:57
ekut Дата: Воскресенье, 27.12.2020, 19:43 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 195
Репутация: 3 ±
Замечаний: 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
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3854
Репутация: 814 ±
Замечаний: 0% ±

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

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD
 
Ответить
СообщениеПрежде чем выйти из макроса - нужно вернуть взад что взяли! :)
Автор - Hugo
Дата добавления - 27.12.2020 в 19:51
ekut Дата: Воскресенье, 27.12.2020, 19:54 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 195
Репутация: 3 ±
Замечаний: 0% ±

Excel 2007
И Вам здравствуйте!!!!!! "Прежде чем выйти из макроса - нужно вернуть взад что взяли!" это как и что???
 
Ответить
СообщениеИ Вам здравствуйте!!!!!! "Прежде чем выйти из макроса - нужно вернуть взад что взяли!" это как и что???
Автор - ekut
Дата добавления - 27.12.2020 в 19:54
Hugo Дата: Воскресенье, 27.12.2020, 19:57 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3854
Репутация: 814 ±
Замечаний: 0% ±

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

webmoney: E265281470651 Z422237915069
USDT TRC20: TN8XeEF17o5KPBD9pNwYzNyruycuAc2mVD
 
Ответить
СообщениеApplication.EnableEvents = False - взяли
Application.EnableEvents = True - положили назад
А когда вышли после "списать" - не положили!
Но это конечно косяк Кузмича...
Автор - Hugo
Дата добавления - 27.12.2020 в 19:57
Kuzmich Дата: Воскресенье, 27.12.2020, 19:59 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 715
Репутация: 157 ±
Замечаний: 0% ±

Excel 2003
Вот так переделал

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]
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target; Range("E:E")) Is Nothing Then     Application.EnableEvents = FalseDim FoundCell As Range  If Target = "списать" Then     Тarget.Offset(; 1) = ""     Тarget.Offset(; 2) = "75%"     Target.Font.ColorIndex = 3     Тarget.Offset(; 2).Font.ColorIndex = 3     Application.EnableEvents = Тrue     Exit Sub  Else    If Target = "продлить" Then       Тarget.Offset(; 1) = Application.InputBox("Введите количество"; Type:=1)       Set FoundCell = Columns("L").Find(Тarget.Offset(; 1); ; xlValues; xlWhole)     If Not FoundCell Is Nothing Then       Тarget.Offset(; 2) = FoundCell.Offset(; 1)       Target.Font.ColorIndex = 5       Тarget.Offset(; 1).Font.ColorIndex = 5       Тarget.Offset(; 2).Font.ColorIndex = 5     Else        MsgBox "В столбце L нет значения: " & Тarget.Offset(; 1)        Тarget.Offset(; 1) = ""        Тarget.Offset(; 2) = ""     End If    End If  End If End If    Application.EnableEvents = ТrueEnd Sub
[/vba]
Автор - Kuzmich
Дата добавления - 27.12.2020 в 19:59
ekut Дата: Воскресенье, 27.12.2020, 20:06 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 195
Репутация: 3 ±
Замечаний: 0% ±

Excel 2007
Гениальненько!!!!!!!!Благодарююююююююю
 
Ответить
СообщениеГениальненько!!!!!!!!Благодарююююююююю
Автор - ekut
Дата добавления - 27.12.2020 в 20:06
bmv98rus Дата: Понедельник, 28.12.2020, 00:02 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4147
Репутация: 772 ±
Замечаний: 0% ±

Excel 2013/2016
Чуток косметики

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


Замечательный Временно просто медведь , процентов на 20.
 
Ответить
СообщениеЧуток косметики
[vba]
Private Sub Worksheet_Change(ByVal Target As Range)Dim FoundCell As Range; Cell As RangeIf 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 = ТrueEnd IfEnd Sub
[/vba]
Автор - bmv98rus
Дата добавления - 28.12.2020 в 00:02
RAN Дата: Понедельник, 28.12.2020, 10:24 | Сообщение № 10
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

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

Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщениеbmv98rus, Миш, а почему индоутку не вставил?
Она как раз под этот файл.
Автор - RAN
Дата добавления - 28.12.2020 в 10:24
bmv98rus Дата: Понедельник, 28.12.2020, 10:56 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4147
Репутация: 772 ±
Замечаний: 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
Поиск:

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