Здравствуйте большие специалисты )
Помогите переделать макрос
При вводе в ячейку B значения "Люди Х" должно появиться окно-вопрос
Введите значение Знач1. Вводим значение, жмем ОК.
Это введенное значение вносим в столбец справа (знач1) от Наименования
в столбец справа через 1 от наименования (знач2) вносим по формуле =Знач1-Знач1/11
в столбец справа через 2 от наименования (знач3) вносим по формуле =(Знач1-Знач2)*0.1
в столбец справа через 3 от наименования (знач4) вносим по формуле =Знач3
Макрос для внесения даты в столбец слева от наименования должен сработать только если в ячейке с датой еще нет значения:
Макрос на добавление нового Имени в Справочник должен сработать только если введено не "Люди Х":
Макрос целиком (то что есть сейчас):
В версии 2003 не работает, сохранил пример в новой.
Помогите переделать макрос
При вводе в ячейку B значения "Люди Х" должно появиться окно-вопрос
Введите значение Знач1. Вводим значение, жмем ОК.
Это введенное значение вносим в столбец справа (знач1) от Наименования
в столбец справа через 1 от наименования (знач2) вносим по формуле =Знач1-Знач1/11
в столбец справа через 2 от наименования (знач3) вносим по формуле =(Знач1-Знач2)*0.1
в столбец справа через 3 от наименования (знач4) вносим по формуле =Знач3
Макрос для внесения даты в столбец слева от наименования должен сработать только если в ячейке с датой еще нет значения:
| Код |
|---|
Dim rg As Range, cell As Range
Set rg = Intersect(Target, Range("B4:B1048576")): If rg Is Nothing Then Exit Sub
For Each cell In rg: cell.Offset(0, -1) = IIf(IsEmpty(cell), Empty, cell.Offset(-1, -1)): Next |
Макрос на добавление нового Имени в Справочник должен сработать только если введено не "Люди Х":
| Код |
|---|
Dim lReply As Long
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B2:B9999")) Is Nothing Then
If IsEmpty(Target) Then Exit Sub
If WorksheetFunction.CountIf(Worksheets("Справочник").Range("Imena"), Target) = 0 Then
lReply = MsgBox("Добавить новое имя " & _
Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Worksheets("Справочник").Range("Imena").Cells(Worksheets("Справочник").Range("Imena").Rows.Count + 1, 1) = Target
End If
End If
End If |
| Код |
|---|
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lReply As Long
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("B2:B9999")) Is Nothing Then
If IsEmpty(Target) Then Exit Sub
If WorksheetFunction.CountIf(Worksheets("Справочник").Range("Imena"), Target) = 0 Then
lReply = MsgBox("Добавить новое имя " & _
Target & " в выпадающий список?", vbYesNo + vbQuestion)
If lReply = vbYes Then
Worksheets("Справочник").Range("Imena").Cells(Worksheets("Справочник").Range("Imena").Rows.Count + 1, 1) = Target
End If
End If
End If
Dim rg As Range, cell As Range
Set rg = Intersect(Target, Range("B4:B1048576")): If rg Is Nothing Then Exit Sub
For Each cell In rg: cell.Offset(0, -1) = IIf(IsEmpty(cell), Empty, cell.Offset(-1, -1)): Next
End Sub |
В версии 2003 не работает, сохранил пример в новой.
Изменено: - 05.11.2017 17:10:09
(не с того листа макросы были. исправил)
