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

Вход

Регистрация

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

 

= Мир MS Excel/Поиск данных по номеру. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 212»
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск данных по номеру. (Макросы/Sub)
Поиск данных по номеру.
DK Дата: Вторник, 06.09.2016, 16:21 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый день.

В Листе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
К сообщению приложен файл: Book.xlsx(12Kb)


Сообщение отредактировал DK - Вторник, 06.09.2016, 16:24
 
Ответить
СообщениеДобрый день.

В Листе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

Автор - DK
Дата добавления - 06.09.2016 в 16:21
Manyasha Дата: Вторник, 06.09.2016, 18:17 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1589
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
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
[/vba]
К сообщению приложен файл: Book-1.xlsm(21Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение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
[/vba]

Автор - Manyasha
Дата добавления - 06.09.2016 в 18:17
DK Дата: Вторник, 06.09.2016, 18:32 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте Manyasha
Да вроде всё подходит. Мне нужно время что бы найти всё точно проверить.
Спасибо Вам!


Сообщение отредактировал DK - Вторник, 06.09.2016, 19:00
 
Ответить
СообщениеЗдравствуйте Manyasha
Да вроде всё подходит. Мне нужно время что бы найти всё точно проверить.
Спасибо Вам!

Автор - DK
Дата добавления - 06.09.2016 в 18:32
DK Дата: Вторник, 06.09.2016, 18:59 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha,
К сожалению не подходит (

Так как если я добавляю в Лист2 ещё один номер 1111111 (снизу приписываю(и заполняю ячейки)), то скрипт просто в Листе1 В5 переделывает первый номер "1111111" на новые данные. А должен не переделывать, а заполнить второй номер "1111111", который находится в Лист1 В10 (заполнить его ячейки J и К)
 
Ответить
СообщениеManyasha,
К сожалению не подходит (

Так как если я добавляю в Лист2 ещё один номер 1111111 (снизу приписываю(и заполняю ячейки)), то скрипт просто в Листе1 В5 переделывает первый номер "1111111" на новые данные. А должен не переделывать, а заполнить второй номер "1111111", который находится в Лист1 В10 (заполнить его ячейки J и К)

Автор - DK
Дата добавления - 06.09.2016 в 18:59
KuklP Дата: Вторник, 06.09.2016, 20:57 | Сообщение № 5
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

Маняша, 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
[/vba]


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Вторник, 06.09.2016, 20:58
 
Ответить
СообщениеМаняша, 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
[/vba]

Автор - KuklP
Дата добавления - 06.09.2016 в 20:57
DK Дата: Среда, 07.09.2016, 10:11 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
KuklP,
Спасибо огромное! Работает :)
 
Ответить
СообщениеKuklP,
Спасибо огромное! Работает :)

Автор - DK
Дата добавления - 07.09.2016 в 10:11
KuklP Дата: Среда, 07.09.2016, 13:19 | Сообщение № 7
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

Это Маняше спасибо, ее работа.


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеЭто Маняше спасибо, ее работа.

Автор - KuklP
Дата добавления - 07.09.2016 в 13:19
DK Дата: Среда, 07.09.2016, 17:12 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
KuklP,
Здравствуйте.

А можно ли немного дополнить скрипт.
В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.

PS
Маняше, я тоже выразил благодарность :)
 
Ответить
Сообщение KuklP,
Здравствуйте.

А можно ли немного дополнить скрипт.
В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.

PS
Маняше, я тоже выразил благодарность :)

Автор - DK
Дата добавления - 07.09.2016 в 17:12
Hugo Дата: Среда, 07.09.2016, 17:38 | Сообщение № 9
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2653
Репутация: 597 ±
Замечаний: 0% ±

KuklP, я не вникал в алгоритм, но точно здесь как ключ нужна ячейка?
[vba]
Код
dic1(.Cells(i, 2)) = i
[/vba]


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069
 
Ответить
СообщениеKuklP, я не вникал в алгоритм, но точно здесь как ключ нужна ячейка?
[vba]
Код
dic1(.Cells(i, 2)) = i
[/vba]

Автор - Hugo
Дата добавления - 07.09.2016 в 17:38
KuklP Дата: Среда, 07.09.2016, 19:43 | Сообщение № 10
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

Игорь, привет. Это извращенная мной Маняшина строка:
[vba]
Код
dic.Add Trim(.Cells(i, 2)), i
[/vba]
:)
А что смущает?


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеИгорь, привет. Это извращенная мной Маняшина строка:
[vba]
Код
dic.Add Trim(.Cells(i, 2)), i
[/vba]
:)
А что смущает?

Автор - KuklP
Дата добавления - 07.09.2016 в 19:43
Hugo Дата: Среда, 07.09.2016, 20:38 | Сообщение № 11
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2653
Репутация: 597 ±
Замечаний: 0% ±

Привет, Сергей!
Просто у Маняши ключом была строка, а у тебя ячейка (объект!).


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069


Сообщение отредактировал Hugo - Среда, 07.09.2016, 20:39
 
Ответить
СообщениеПривет, Сергей!
Просто у Маняши ключом была строка, а у тебя ячейка (объект!).

Автор - Hugo
Дата добавления - 07.09.2016 в 20:38
KuklP Дата: Среда, 07.09.2016, 20:58 | Сообщение № 12
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

И что? Работает же :), не ну для особо придирчивых можно в строку переделать: .Cells(i, 2) & "".
Просто я сначала использовал пробел вместо "@", поэтому поубирал тримы. А потом не стал заморачиваться, да и недосуг было. Закон радиолюбителя: Работает - не ремонтируй! :D


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеИ что? Работает же :), не ну для особо придирчивых можно в строку переделать: .Cells(i, 2) & "".
Просто я сначала использовал пробел вместо "@", поэтому поубирал тримы. А потом не стал заморачиваться, да и недосуг было. Закон радиолюбителя: Работает - не ремонтируй! :D

Автор - KuklP
Дата добавления - 07.09.2016 в 20:58
Hugo Дата: Среда, 07.09.2016, 22:46 | Сообщение № 13
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2653
Репутация: 597 ±
Замечаний: 0% ±

Ну просто ячейка и значение ячейки - это разные ключи. Значения на листе могут повторяться, а ячейки все уникальны.
Поэтому код никогда не выходит на
[vba]
Код
dic1.Remove .Cells(i, 2)
[/vba]


excel@nxt.ru
webmoney: E265281470651 R418926282008 Z422237915069
 
Ответить
СообщениеНу просто ячейка и значение ячейки - это разные ключи. Значения на листе могут повторяться, а ячейки все уникальны.
Поэтому код никогда не выходит на
[vba]
Код
dic1.Remove .Cells(i, 2)
[/vba]

Автор - Hugo
Дата добавления - 07.09.2016 в 22:46
DK Дата: Четверг, 08.09.2016, 10:28 | Сообщение № 14
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте.

А можно ли немного дополнить скрипт.
В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.

И что бы сам скрипт работал не после нажатия кнопку "Тест", а автоматически после заполнения ячейки в столбце А в Листе2.
 
Ответить
СообщениеЗдравствуйте.

А можно ли немного дополнить скрипт.
В Листе2 напротив каждого номера, в столбике Ф, вывести подтверждение, что ДА-Номер найден и соответственно НЕТ-не найден.

И что бы сам скрипт работал не после нажатия кнопку "Тест", а автоматически после заполнения ячейки в столбце А в Листе2.

Автор - DK
Дата добавления - 08.09.2016 в 10:28
Manyasha Дата: Четверг, 08.09.2016, 10:58 | Сообщение № 15
Группа: Модераторы
Ранг: Старожил
Сообщений: 1589
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
DK, проверяйте
К сообщению приложен файл: Book-2.xlsm(22Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеDK, проверяйте

Автор - Manyasha
Дата добавления - 08.09.2016 в 10:58
DK Дата: Четверг, 08.09.2016, 12:12 | Сообщение № 16
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha,
Ну просто Гениально!)
Спасибо Вам огромное!
PS
А как можно здесь отправить личное сообщение?


Сообщение отредактировал DK - Четверг, 08.09.2016, 12:17
 
Ответить
СообщениеManyasha,
Ну просто Гениально!)
Спасибо Вам огромное!
PS
А как можно здесь отправить личное сообщение?

Автор - DK
Дата добавления - 08.09.2016 в 12:12
Manyasha Дата: Четверг, 08.09.2016, 12:31 | Сообщение № 17
Группа: Модераторы
Ранг: Старожил
Сообщений: 1589
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
DK, кнопка Приват под постом пользователя. Или в профиле.


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеDK, кнопка Приват под постом пользователя. Или в профиле.

Автор - Manyasha
Дата добавления - 08.09.2016 в 12:31
DK Дата: Четверг, 08.09.2016, 12:58 | Сообщение № 18
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
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 - Четверг, 08.09.2016, 12:59
 
Ответить
Сообщение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
Дата добавления - 08.09.2016 в 12:58
Manyasha Дата: Четверг, 08.09.2016, 13:15 | Сообщение № 19
Группа: Модераторы
Ранг: Старожил
Сообщений: 1589
Репутация: 669 ±
Замечаний: 0% ±

Excel 2007, 2010
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
[/vba]
К сообщению приложен файл: Book-3.xlsm(24Kb)


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщение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
[/vba]

Автор - Manyasha
Дата добавления - 08.09.2016 в 13:15
DK Дата: Четверг, 08.09.2016, 13:35 | Сообщение № 20
Группа: Пользователи
Ранг: Новичок
Сообщений: 12
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha,

К сожалению скрипт работает не корректно.

1)Если присутствует ДА или НЕТ, то "мой скрипт" не срабатывает - курсор не перескакивает на заданную ячейку (после нажатия ввода (переход вправо в настройках))
Эксперимент: Начните вводить номер уже в заполненных ячейках с результатом Да или Нет. И переход просто будет постоянно идти вправо.

2)Если пропустить одну строку в столбике А Лист2, то Ваш скрипт не срабатывает, но зато срабатывает "мой"
Эксперимент: Пропустите строку в Столбике А оставьте пустой, а в следующей строке введите номер, тогда Ваш скрипт не сработает, и как я понимаю если не будет стоять "Да" или "Нет", то "мой" скрипт сработает и курсор перескочит в заданную цель
 
Ответить
Сообщение Manyasha,

К сожалению скрипт работает не корректно.

1)Если присутствует ДА или НЕТ, то "мой скрипт" не срабатывает - курсор не перескакивает на заданную ячейку (после нажатия ввода (переход вправо в настройках))
Эксперимент: Начните вводить номер уже в заполненных ячейках с результатом Да или Нет. И переход просто будет постоянно идти вправо.

2)Если пропустить одну строку в столбике А Лист2, то Ваш скрипт не срабатывает, но зато срабатывает "мой"
Эксперимент: Пропустите строку в Столбике А оставьте пустой, а в следующей строке введите номер, тогда Ваш скрипт не сработает, и как я понимаю если не будет стоять "Да" или "Нет", то "мой" скрипт сработает и курсор перескочит в заданную цель

Автор - DK
Дата добавления - 08.09.2016 в 13:35
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск данных по номеру. (Макросы/Sub)
Страница 1 из 212»
Поиск:

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