В Листе1, в столбце В есть номера (товар который должен быть на складе) В Листе2, в столбце А номера (товар), который действительно пришёл на склад. Моя проблема следующая. Мне нужно что бы по номеру из Листа2 в столбце А происходил поиск в Листе1 в столбце В и при нахождении. Заполнял в Листе1 столбики "J" и "К" из Листа2 с В и С. Вот так. Лист1 J1= Лист2 В1 Лист1 К1= Лист2 С1
Я не могу решить это с помощью ВПР итд так как: 1) Нужно что бы поиск происходил только в ячейках закрашенных в оранжевый цвет. И самое главное 2) Что бы только один раз были присвоены данные по номеру.
Поясняю. Если в Листе1 допустим 2 раза указан номер 1111111, а в Листе2 только один раз, то именно один раз должны быть присвоены данные в столбцах J и К. (один раз любому из номеров в Листе1) Например когда я пользуюсь ВПР то, автоматически заполняются все совпадения не смотря на то, что в Листе2 товар с номером 1111111 присутствует только один раз. В Листе1 Все ячейки с номером 1111111 присваивают себе сразу данные.
Объяснил как мог, не судите строго пожалуйста. Я новечёк здесь. И первый раз сталкиваюсь именно с форумами экселя, где ячейки, столбцы итд... В конце всё выходит довольно запутанно. Решение по VBA
Добрый день.
В Листе1, в столбце В есть номера (товар который должен быть на складе) В Листе2, в столбце А номера (товар), который действительно пришёл на склад. Моя проблема следующая. Мне нужно что бы по номеру из Листа2 в столбце А происходил поиск в Листе1 в столбце В и при нахождении. Заполнял в Листе1 столбики "J" и "К" из Листа2 с В и С. Вот так. Лист1 J1= Лист2 В1 Лист1 К1= Лист2 С1
Я не могу решить это с помощью ВПР итд так как: 1) Нужно что бы поиск происходил только в ячейках закрашенных в оранжевый цвет. И самое главное 2) Что бы только один раз были присвоены данные по номеру.
Поясняю. Если в Листе1 допустим 2 раза указан номер 1111111, а в Листе2 только один раз, то именно один раз должны быть присвоены данные в столбцах J и К. (один раз любому из номеров в Листе1) Например когда я пользуюсь ВПР то, автоматически заполняются все совпадения не смотря на то, что в Листе2 товар с номером 1111111 присутствует только один раз. В Листе1 Все ячейки с номером 1111111 присваивают себе сразу данные.
Объяснил как мог, не судите строго пожалуйста. Я новечёк здесь. И первый раз сталкиваюсь именно с форумами экселя, где ячейки, столбцы итд... В конце всё выходит довольно запутанно. Решение по VBADK
Sub test() Dim lr&, i&, dic As Object, arrKeys, arrItems Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2)
With sh1 lr = .Cells(Rows.Count, 2).End(xlUp).Row .Cells(1, "j").Resize(lr, 2).ClearContents Set dic = CreateObject("scripting.dictionary") For i = 1 To lr If Not dic.Exists(Trim(.Cells(i, 2))) And .Cells(i, 2) <> "" And .Cells(i, 2).Interior.Color = 4626167 Then dic.Add Trim(.Cells(i, 2)), i Set res = sh2.Columns(1).Find(What:=.Cells(i, 2), LookAt:=xlWhole) If Not res Is Nothing Then .Cells(i, "j").Resize(, 2) = sh2.Cells(res.Row, "b").Resize(, 2).Value End If End If Next i End With End Sub
[/vba]
DK, здравствуйте. Так подойдет? [vba]
Код
Sub test() Dim lr&, i&, dic As Object, arrKeys, arrItems Dim sh1 As Worksheet, sh2 As Worksheet Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2)
With sh1 lr = .Cells(Rows.Count, 2).End(xlUp).Row .Cells(1, "j").Resize(lr, 2).ClearContents Set dic = CreateObject("scripting.dictionary") For i = 1 To lr If Not dic.Exists(Trim(.Cells(i, 2))) And .Cells(i, 2) <> "" And .Cells(i, 2).Interior.Color = 4626167 Then dic.Add Trim(.Cells(i, 2)), i Set res = sh2.Columns(1).Find(What:=.Cells(i, 2), LookAt:=xlWhole) If Not res Is Nothing Then .Cells(i, "j").Resize(, 2) = sh2.Cells(res.Row, "b").Resize(, 2).Value End If End If Next i End With End Sub
Так как если я добавляю в Лист2 ещё один номер 1111111 (снизу приписываю(и заполняю ячейки)), то скрипт просто в Листе1 В5 переделывает первый номер "1111111" на новые данные. А должен не переделывать, а заполнить второй номер "1111111", который находится в Лист1 В10 (заполнить его ячейки J и К)
Manyasha, К сожалению не подходит (
Так как если я добавляю в Лист2 ещё один номер 1111111 (снизу приписываю(и заполняю ячейки)), то скрипт просто в Листе1 В5 переделывает первый номер "1111111" на новые данные. А должен не переделывать, а заполнить второй номер "1111111", который находится в Лист1 В10 (заполнить его ячейки J и К)DK
Sub test() Dim lr&, i&, dic1 As Object, arrKeys, arrItems Dim sh1 As Worksheet, sh2 As Worksheet, res As Range Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2)
With sh1 lr = .Cells(Rows.Count, 2).End(xlUp).Row .Cells(1, "j").Resize(lr, 2).ClearContents Set dic1 = CreateObject("scripting.dictionary") For i = 1 To lr If Not dic1.Exists(.Cells(i, 2)) Then If .Cells(i, 2) <> "" And .Cells(i, 2).Interior.Color = 4626167 Then dic1(.Cells(i, 2)) = i Set res = sh2.Columns(1).Find(What:=.Cells(i, 2), after:=sh2.[a65536], LookAt:=xlWhole, SearchDirection:=xlNext) If Not res Is Nothing Then .Cells(i, "j").Resize(, 2) = sh2.Cells(res.Row, "b").Resize(, 2).Value res.Value = res.Value & "@" End If End If Else dic1.Remove .Cells(i, 2) End If Next i dic1.RemoveAll End With sh2.UsedRange.Columns(1).Replace "@", "", xlPart End Sub
[/vba]
Маняша, res не объявлена. DK, может так: [vba]
Код
Sub test() Dim lr&, i&, dic1 As Object, arrKeys, arrItems Dim sh1 As Worksheet, sh2 As Worksheet, res As Range Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2)
With sh1 lr = .Cells(Rows.Count, 2).End(xlUp).Row .Cells(1, "j").Resize(lr, 2).ClearContents Set dic1 = CreateObject("scripting.dictionary") For i = 1 To lr If Not dic1.Exists(.Cells(i, 2)) Then If .Cells(i, 2) <> "" And .Cells(i, 2).Interior.Color = 4626167 Then dic1(.Cells(i, 2)) = i Set res = sh2.Columns(1).Find(What:=.Cells(i, 2), after:=sh2.[a65536], LookAt:=xlWhole, SearchDirection:=xlNext) If Not res Is Nothing Then .Cells(i, "j").Resize(, 2) = sh2.Cells(res.Row, "b").Resize(, 2).Value res.Value = res.Value & "@" End If End If Else dic1.Remove .Cells(i, 2) End If Next i dic1.RemoveAll End With sh2.UsedRange.Columns(1).Replace "@", "", xlPart End Sub
А можно ли немного дополнить скрипт. В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.
PS Маняше, я тоже выразил благодарность
KuklP, Здравствуйте.
А можно ли немного дополнить скрипт. В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.
И что? Работает же :), не ну для особо придирчивых можно в строку переделать: .Cells(i, 2) & "". Просто я сначала использовал пробел вместо "@", поэтому поубирал тримы. А потом не стал заморачиваться, да и недосуг было. Закон радиолюбителя: Работает - не ремонтируй!
И что? Работает же :), не ну для особо придирчивых можно в строку переделать: .Cells(i, 2) & "". Просто я сначала использовал пробел вместо "@", поэтому поубирал тримы. А потом не стал заморачиваться, да и недосуг было. Закон радиолюбителя: Работает - не ремонтируй! KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Ну просто ячейка и значение ячейки - это разные ключи. Значения на листе могут повторяться, а ячейки все уникальны. Поэтому код никогда не выходит на [vba]
Код
dic1.Remove .Cells(i, 2)
[/vba]
Ну просто ячейка и значение ячейки - это разные ключи. Значения на листе могут повторяться, а ячейки все уникальны. Поэтому код никогда не выходит на [vba]
А можно ли немного дополнить скрипт. В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.
И что бы сам скрипт работал не после нажатия кнопку "Тест", а автоматически после заполнения ячейки в столбце А в Листе2.
Здравствуйте.
А можно ли немного дополнить скрипт. В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.
И что бы сам скрипт работал не после нажатия кнопку "Тест", а автоматически после заполнения ячейки в столбце А в Листе2.DK
Manyasha, И самый последний вопрос на эту тему. Как мне совместить работу вашего макроса с этим [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If ActiveCell.Column <> 4 Then Exit Sub Cells(ActiveCell.Row + 1, ActiveCell.Column - 3).Activate End Sub
[/vba] Я вставил вниз вашего кода. Вроде как 2 Макроса на лист. А выдаёт "Ambiguoses name detected: Workscheet_Change " :( ps Никогда не сталкивался с VBA, вот буквально второй день... далёк очень.
Manyasha, И самый последний вопрос на эту тему. Как мне совместить работу вашего макроса с этим [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If ActiveCell.Column <> 4 Then Exit Sub Cells(ActiveCell.Row + 1, ActiveCell.Column - 3).Activate End Sub
[/vba] Я вставил вниз вашего кода. Вроде как 2 Макроса на лист. А выдаёт "Ambiguoses name detected: Workscheet_Change " :( ps Никогда не сталкивался с VBA, вот буквально второй день... далёк очень.DK
Сообщение отредактировал DK - Четверг, 08.09.2016, 12:59
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
Dim lr&, lr2&, i&, dic1 As Object, arrKeys, arrItems Dim sh1 As Worksheet, sh2 As Worksheet, res As Range Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2)
lr2 = Cells(1, 1).CurrentRegion.Rows.Count 'Если редактируем столбцы А:С If Not Intersect(Target, Range("a1:c" & lr2)) Is Nothing Then With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
Cells(1, "d").Resize(lr2).ClearContents With sh1 lr = .Cells(Rows.Count, 2).End(xlUp).Row .Cells(1, "j").Resize(lr, 2).ClearContents Set dic1 = CreateObject("scripting.dictionary") For i = 1 To lr If Not dic1.Exists(.Cells(i, 2)) Then If .Cells(i, 2) <> "" And .Cells(i, 2).Interior.Color = 4626167 Then dic1(.Cells(i, 2)) = i Set res = sh2.Columns(1).Find(What:=.Cells(i, 2), after:=sh2.[a65536], LookAt:=xlWhole, SearchDirection:=xlNext) If Not res Is Nothing Then .Cells(i, "j").Resize(, 2) = sh2.Cells(res.Row, "b").Resize(, 2).Value sh2.Cells(res.Row, "d") = "ДА" res.Value = res.Value & "@" End If End If Else dic1.Remove .Cells(i, 2) End If Next i dic1.RemoveAll End With With sh2 .UsedRange.Columns(1).Replace "@", "", xlPart .Cells(1, "d").Resize(lr2).SpecialCells(xlCellTypeBlanks) = "НЕТ" End With
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With 'Если редактируем столбец №4 ElseIf ActiveCell.Column = 4 Then Cells(ActiveCell.Row + 1, ActiveCell.Column - 3).Activate End If End Sub
[/vba]
Возможно я плохо сделала, что не оставила макрос отдельно в модуле. Так наверное понятней должно быть: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim lr2& lr2 = Cells(1, 1).CurrentRegion.Rows.Count 'Если редактируем столбцы А:С If Not Intersect(Target, Range("a1:c" & lr2)) Is Nothing Then refrashSheet'Вызываем наш макрос обновления листа 'Если редактируем столбец №4 ElseIf ActiveCell.Column = 4 Then Cells(ActiveCell.Row + 1, ActiveCell.Column - 3).Activate End If End Sub
[/vba]
DK, все должно быть в одном макросе: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub
Dim lr&, lr2&, i&, dic1 As Object, arrKeys, arrItems Dim sh1 As Worksheet, sh2 As Worksheet, res As Range Set sh1 = ThisWorkbook.Sheets(1) Set sh2 = ThisWorkbook.Sheets(2)
lr2 = Cells(1, 1).CurrentRegion.Rows.Count 'Если редактируем столбцы А:С If Not Intersect(Target, Range("a1:c" & lr2)) Is Nothing Then With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
Cells(1, "d").Resize(lr2).ClearContents With sh1 lr = .Cells(Rows.Count, 2).End(xlUp).Row .Cells(1, "j").Resize(lr, 2).ClearContents Set dic1 = CreateObject("scripting.dictionary") For i = 1 To lr If Not dic1.Exists(.Cells(i, 2)) Then If .Cells(i, 2) <> "" And .Cells(i, 2).Interior.Color = 4626167 Then dic1(.Cells(i, 2)) = i Set res = sh2.Columns(1).Find(What:=.Cells(i, 2), after:=sh2.[a65536], LookAt:=xlWhole, SearchDirection:=xlNext) If Not res Is Nothing Then .Cells(i, "j").Resize(, 2) = sh2.Cells(res.Row, "b").Resize(, 2).Value sh2.Cells(res.Row, "d") = "ДА" res.Value = res.Value & "@" End If End If Else dic1.Remove .Cells(i, 2) End If Next i dic1.RemoveAll End With With sh2 .UsedRange.Columns(1).Replace "@", "", xlPart .Cells(1, "d").Resize(lr2).SpecialCells(xlCellTypeBlanks) = "НЕТ" End With
With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlCalculationAutomatic: End With 'Если редактируем столбец №4 ElseIf ActiveCell.Column = 4 Then Cells(ActiveCell.Row + 1, ActiveCell.Column - 3).Activate End If End Sub
[/vba]
Возможно я плохо сделала, что не оставила макрос отдельно в модуле. Так наверное понятней должно быть: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim lr2& lr2 = Cells(1, 1).CurrentRegion.Rows.Count 'Если редактируем столбцы А:С If Not Intersect(Target, Range("a1:c" & lr2)) Is Nothing Then refrashSheet'Вызываем наш макрос обновления листа 'Если редактируем столбец №4 ElseIf ActiveCell.Column = 4 Then Cells(ActiveCell.Row + 1, ActiveCell.Column - 3).Activate End If End Sub
1)Если присутствует ДА или НЕТ, то "мой скрипт" не срабатывает - курсор не перескакивает на заданную ячейку (после нажатия ввода (переход вправо в настройках)) Эксперимент: Начните вводить номер уже в заполненных ячейках с результатом Да или Нет. И переход просто будет постоянно идти вправо.
2)Если пропустить одну строку в столбике А Лист2, то Ваш скрипт не срабатывает, но зато срабатывает "мой" Эксперимент: Пропустите строку в Столбике А оставьте пустой, а в следующей строке введите номер, тогда Ваш скрипт не сработает, и как я понимаю если не будет стоять "Да" или "Нет", то "мой" скрипт сработает и курсор перескочит в заданную цель
Manyasha,
К сожалению скрипт работает не корректно.
1)Если присутствует ДА или НЕТ, то "мой скрипт" не срабатывает - курсор не перескакивает на заданную ячейку (после нажатия ввода (переход вправо в настройках)) Эксперимент: Начните вводить номер уже в заполненных ячейках с результатом Да или Нет. И переход просто будет постоянно идти вправо.
2)Если пропустить одну строку в столбике А Лист2, то Ваш скрипт не срабатывает, но зато срабатывает "мой" Эксперимент: Пропустите строку в Столбике А оставьте пустой, а в следующей строке введите номер, тогда Ваш скрипт не сработает, и как я понимаю если не будет стоять "Да" или "Нет", то "мой" скрипт сработает и курсор перескочит в заданную цельDK
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
