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

Вход

Регистрация

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

 

= Мир MS Excel/Замена данных в исходной ячейке - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена данных в исходной ячейке (Макросы/Sub)
Замена данных в исходной ячейке
Gameower Дата: Вторник, 01.11.2016, 08:47 | Сообщение № 1
Группа: Пользователи
Ранг: Участник
Сообщений: 95
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Доброго времени суток коллеги.
У меня такая задача:
Есть исходная ячейка в ней вводим артикул, система дает уведомительное окно о том что он изменен на новый, вопрос можно ли сделать так что бы в этом уведомительном окне вместо кнопки "ОК" была кнопка "Заменить" и при ее нажатии автоматически происходило бы изменение старого артикула на новый в той же ячейке?
К сообщению приложен файл: 7162978.xlsm (80.5 Kb)


Сообщение отредактировал Gameower - Вторник, 01.11.2016, 09:06
 
Ответить
СообщениеДоброго времени суток коллеги.
У меня такая задача:
Есть исходная ячейка в ней вводим артикул, система дает уведомительное окно о том что он изменен на новый, вопрос можно ли сделать так что бы в этом уведомительном окне вместо кнопки "ОК" была кнопка "Заменить" и при ее нажатии автоматически происходило бы изменение старого артикула на новый в той же ячейке?
Автор - Gameower
Дата добавления - 01.11.2016 в 08:47
Manyasha Дата: Вторник, 01.11.2016, 09:18 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
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

Application.EnableEvents = False
Target.Value = rep(Target.Value)
Application.EnableEvents = True

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]
К сообщению приложен файл: 7162978-1.xlsm (80.5 Kb)

ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение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

Application.EnableEvents = False
Target.Value = rep(Target.Value)
Application.EnableEvents = True

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]
Автор - Manyasha
Дата добавления - 01.11.2016 в 09:18
Gameower Дата: Вторник, 01.11.2016, 11:15 | Сообщение № 3
Группа: Пользователи
Ранг: Участник
Сообщений: 95
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
все работает. Всем спасибо
 
Ответить
Сообщениевсе работает. Всем спасибо
Автор - Gameower
Дата добавления - 01.11.2016 в 11:15
Gameower Дата: Вторник, 01.11.2016, 13:00 | Сообщение № 4
Группа: Пользователи
Ранг: Участник
Сообщений: 95
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, а у меня есть ссылки где не требуется замена артикула, есть просто информация. как бы их оставить так же как и была просто информация
файлик прикаладываю
К сообщению приложен файл: 5041918.xlsm (70.3 Kb)
 
Ответить
СообщениеManyasha, а у меня есть ссылки где не требуется замена артикула, есть просто информация. как бы их оставить так же как и была просто информация
файлик прикаладываю
Автор - Gameower
Дата добавления - 01.11.2016 в 13:00
Manyasha Дата: Среда, 02.11.2016, 09:43 | Сообщение № 5
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
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

Application.EnableEvents = False
Target.Value = rep(Target.Value)
Application.EnableEvents = True

'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]
К сообщению приложен файл: 5041918-1.xlsm (71.1 Kb)

ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение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

Application.EnableEvents = False
Target.Value = rep(Target.Value)
Application.EnableEvents = True

'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]
Автор - Manyasha
Дата добавления - 02.11.2016 в 09:43
Gameower Дата: Четверг, 03.11.2016, 06:18 | Сообщение № 6
Группа: Пользователи
Ранг: Участник
Сообщений: 95
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, будем тестировать!
 
Ответить
СообщениеManyasha, будем тестировать!
Автор - Gameower
Дата добавления - 03.11.2016 в 06:18
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Замена данных в исходной ячейке (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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