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

Вход

Регистрация

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

 

= Мир MS Excel/Перенос уникальных значений с проверкой на неповторяемость - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос уникальных значений с проверкой на неповторяемость (Макросы Sub)
Перенос уникальных значений с проверкой на неповторяемость
grano Дата: Четверг, 24.10.2013, 15:25 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Приветствую всех.

Прошу помощи с написанием макроса, выбирающего новые уникальные значения из одного листа, проверяющего их на неповторяемость в другом листе и записывающего уникальные (Excel 2007).

В книге имеются два листа.

В первом листе (в прилагаемом файле лист "Все_клиенты") содержится список всех клиентов (номер (UID) и наименование) на дату создания файла.

Во второй лист (в прилагаемом файле лист "Клиенты_на_рассмотрении") периодически заносятся операции, совершенные с
клиентами за определенный период. При этом могут появляться как клиенты, имеющиеся в первом листе, так и новые клиенты. Клиенты во втором листе могут повторяться неоднократно.

Задача - по мере необходимости выбирать уникальные новые записи (UID и наименование клиента) из второго листа и переносить их в первый.

Найденный и модифицированный макрос умеет выбирать новые записи, но не умеет проверять их на повторяемость с уже имеющимися данными на первом листе. Также он некорректно определяет позицию, с которой надо начинать запись (необходимо заносить их с первой пустой позиции).

Спасибо.
К сообщению приложен файл: __.xlsm (27.1 Kb)
 
Ответить
СообщениеПриветствую всех.

Прошу помощи с написанием макроса, выбирающего новые уникальные значения из одного листа, проверяющего их на неповторяемость в другом листе и записывающего уникальные (Excel 2007).

В книге имеются два листа.

В первом листе (в прилагаемом файле лист "Все_клиенты") содержится список всех клиентов (номер (UID) и наименование) на дату создания файла.

Во второй лист (в прилагаемом файле лист "Клиенты_на_рассмотрении") периодически заносятся операции, совершенные с
клиентами за определенный период. При этом могут появляться как клиенты, имеющиеся в первом листе, так и новые клиенты. Клиенты во втором листе могут повторяться неоднократно.

Задача - по мере необходимости выбирать уникальные новые записи (UID и наименование клиента) из второго листа и переносить их в первый.

Найденный и модифицированный макрос умеет выбирать новые записи, но не умеет проверять их на повторяемость с уже имеющимися данными на первом листе. Также он некорректно определяет позицию, с которой надо начинать запись (необходимо заносить их с первой пустой позиции).

Спасибо.

Автор - grano
Дата добавления - 24.10.2013 в 15:25
nilem Дата: Четверг, 24.10.2013, 16:54 | Сообщение № 2
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
Привет, grano
вот так попробуйте
[vba]
Код
Sub ertert()
Dim x, i&, j&
With Sheets("Все_клиенты")
     x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 1 To UBound(x)
         .Item(x(i, 1)) = Empty
     Next i
     With Sheets("Клиенты_на_рассмотрении")
         x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
     End With
     For i = 1 To UBound(x)
         If Not .Exists(x(i, 1)) Then
             .Item(x(i, 1)) = Empty
             j = j + 1: x(j, 1) = x(i, 1): x(j, 2) = x(i, 2)
         End If
     Next i
End With
With Sheets("Все_клиенты")
     If j > 0 Then .Cells(Rows.Count, 1).End(xlUp)(2).Resize(j, 2).Value = x
     .Activate
End With
End Sub
[/vba]


Яндекс.Деньги 4100159601573
 
Ответить
СообщениеПривет, grano
вот так попробуйте
[vba]
Код
Sub ertert()
Dim x, i&, j&
With Sheets("Все_клиенты")
     x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 1 To UBound(x)
         .Item(x(i, 1)) = Empty
     Next i
     With Sheets("Клиенты_на_рассмотрении")
         x = .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
     End With
     For i = 1 To UBound(x)
         If Not .Exists(x(i, 1)) Then
             .Item(x(i, 1)) = Empty
             j = j + 1: x(j, 1) = x(i, 1): x(j, 2) = x(i, 2)
         End If
     Next i
End With
With Sheets("Все_клиенты")
     If j > 0 Then .Cells(Rows.Count, 1).End(xlUp)(2).Resize(j, 2).Value = x
     .Activate
End With
End Sub
[/vba]

Автор - nilem
Дата добавления - 24.10.2013 в 16:54
grano Дата: Четверг, 24.10.2013, 17:05 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
nilem, благодарю за оперативную помощь!!!
 
Ответить
Сообщениеnilem, благодарю за оперативную помощь!!!

Автор - grano
Дата добавления - 24.10.2013 в 17:05
nilem Дата: Четверг, 24.10.2013, 17:11 | Сообщение № 4
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
Пожалста :)


Яндекс.Деньги 4100159601573
 
Ответить
СообщениеПожалста :)

Автор - nilem
Дата добавления - 24.10.2013 в 17:11
KuklP Дата: Четверг, 24.10.2013, 19:54 | Сообщение № 5
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
А на другом форуме отписаться?
http://www.sql.ru/forum....yaemost


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеА на другом форуме отписаться?
http://www.sql.ru/forum....yaemost

Автор - KuklP
Дата добавления - 24.10.2013 в 19:54
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос уникальных значений с проверкой на неповторяемость (Макросы Sub)
  • Страница 1 из 1
  • 1
Поиск:

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