Прошу помощи с написанием макроса, выбирающего новые уникальные значения из одного листа, проверяющего их на неповторяемость в другом листе и записывающего уникальные (Excel 2007).
В книге имеются два листа.
В первом листе (в прилагаемом файле лист "Все_клиенты") содержится список всех клиентов (номер (UID) и наименование) на дату создания файла.
Во второй лист (в прилагаемом файле лист "Клиенты_на_рассмотрении") периодически заносятся операции, совершенные с клиентами за определенный период. При этом могут появляться как клиенты, имеющиеся в первом листе, так и новые клиенты. Клиенты во втором листе могут повторяться неоднократно.
Задача - по мере необходимости выбирать уникальные новые записи (UID и наименование клиента) из второго листа и переносить их в первый.
Найденный и модифицированный макрос умеет выбирать новые записи, но не умеет проверять их на повторяемость с уже имеющимися данными на первом листе. Также он некорректно определяет позицию, с которой надо начинать запись (необходимо заносить их с первой пустой позиции).
Спасибо.
Приветствую всех.
Прошу помощи с написанием макроса, выбирающего новые уникальные значения из одного листа, проверяющего их на неповторяемость в другом листе и записывающего уникальные (Excel 2007).
В книге имеются два листа.
В первом листе (в прилагаемом файле лист "Все_клиенты") содержится список всех клиентов (номер (UID) и наименование) на дату создания файла.
Во второй лист (в прилагаемом файле лист "Клиенты_на_рассмотрении") периодически заносятся операции, совершенные с клиентами за определенный период. При этом могут появляться как клиенты, имеющиеся в первом листе, так и новые клиенты. Клиенты во втором листе могут повторяться неоднократно.
Задача - по мере необходимости выбирать уникальные новые записи (UID и наименование клиента) из второго листа и переносить их в первый.
Найденный и модифицированный макрос умеет выбирать новые записи, но не умеет проверять их на повторяемость с уже имеющимися данными на первом листе. Также он некорректно определяет позицию, с которой надо начинать запись (необходимо заносить их с первой пустой позиции).
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]
Привет, 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