Доброго времени суток коллеги. У меня такая задача: Есть исходная ячейка в ней вводим артикул, система дает уведомительное окно о том что он изменен на новый, вопрос можно ли сделать так что бы в этом уведомительном окне вместо кнопки "ОК" была кнопка "Заменить" и при ее нажатии автоматически происходило бы изменение старого артикула на новый в той же ячейке?
Доброго времени суток коллеги. У меня такая задача: Есть исходная ячейка в ней вводим артикул, система дает уведомительное окно о том что он изменен на новый, вопрос можно ли сделать так что бы в этом уведомительном окне вместо кнопки "ОК" была кнопка "Заменить" и при ее нажатии автоматически происходило бы изменение старого артикула на новый в той же ячейке?Gameower
If d.Count = 0 Then d.RemoveAll With Sheets("Тех замены") n = .Cells(Rows.Count, 2).End(xlUp).Row m = .Range("a1:b" & n).Value For i = 1 To UBound(m) If Not d.exists(m(i, 1)) Then d.Add m(i, 1), m(i, 2) Next End With End If 'Добавила If d.exists(Target.Value) Then If MsgBox("" & d.Item(Target.Value) & vbCrLf & "Заменить артикул?", vbYesNo) = vbYes Then temp = Split(d.Item(Target.Value), " ") Target.Value = temp(UBound(temp)) End If End If End Sub
[/vba]
Gameower, можно так: добавила код в последний if с выводом сообщения [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim m, i&, n&, s$, temp If Target.Column <> 4 Or Target.CountLarge > 1 Then Exit Sub
If d.Count = 0 Then d.RemoveAll With Sheets("Тех замены") n = .Cells(Rows.Count, 2).End(xlUp).Row m = .Range("a1:b" & n).Value For i = 1 To UBound(m) If Not d.exists(m(i, 1)) Then d.Add m(i, 1), m(i, 2) Next End With End If 'Добавила If d.exists(Target.Value) Then If MsgBox("" & d.Item(Target.Value) & vbCrLf & "Заменить артикул?", vbYesNo) = vbYes Then temp = Split(d.Item(Target.Value), " ") Target.Value = temp(UBound(temp)) End If End If End Sub
Manyasha, а у меня есть ссылки где не требуется замена артикула, есть просто информация. как бы их оставить так же как и была просто информация файлик прикаладываю
Manyasha, а у меня есть ссылки где не требуется замена артикула, есть просто информация. как бы их оставить так же как и была просто информация файлик прикаладываюGameower
Gameower, тогда нужно как-то пометить строки, для которых можно производить замену. Например единичками в столбце С (лист тех.замены): [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim m, i&, n&, s$, temp, typeMsg#, msg$ If Target.Column <> 4 Or Target.CountLarge > 1 Then Exit Sub
'If d.Count = 0 Then d.RemoveAll With Sheets("Тех замены") n = .Cells(Rows.Count, 2).End(xlUp).Row m = .Range("a1:c" & n).Value For i = 1 To UBound(m) If Not d.exists(m(i, 1)) Then d.Add m(i, 1), m(i, 2) & "@@" & CInt(m(i, 3)) Next End With 'End If 'Добавила If d.exists(Target.Value) Then typeMsg = vbYesNo If Split(d.Item(Target.Value), "@@")(1) = 1 Then typeMsg = vbYesNo msg = Split(d.Item(Target.Value), "@@")(0) & vbCrLf & "Заменить артикул?" Else typeMsg = vbOKOnly msg = Split(d.Item(Target.Value), "@@")(0) End If If MsgBox(msg, typeMsg) = vbYes Then temp = Split(d.Item(Target.Value), " ") Target.Value = Split(temp(UBound(temp)), "@@")(0) End If End If End Sub
[/vba]
Gameower, тогда нужно как-то пометить строки, для которых можно производить замену. Например единичками в столбце С (лист тех.замены): [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim m, i&, n&, s$, temp, typeMsg#, msg$ If Target.Column <> 4 Or Target.CountLarge > 1 Then Exit Sub
'If d.Count = 0 Then d.RemoveAll With Sheets("Тех замены") n = .Cells(Rows.Count, 2).End(xlUp).Row m = .Range("a1:c" & n).Value For i = 1 To UBound(m) If Not d.exists(m(i, 1)) Then d.Add m(i, 1), m(i, 2) & "@@" & CInt(m(i, 3)) Next End With 'End If 'Добавила If d.exists(Target.Value) Then typeMsg = vbYesNo If Split(d.Item(Target.Value), "@@")(1) = 1 Then typeMsg = vbYesNo msg = Split(d.Item(Target.Value), "@@")(0) & vbCrLf & "Заменить артикул?" Else typeMsg = vbOKOnly msg = Split(d.Item(Target.Value), "@@")(0) End If If MsgBox(msg, typeMsg) = vbYes Then temp = Split(d.Item(Target.Value), " ") Target.Value = Split(temp(UBound(temp)), "@@")(0) End If End If End Sub