AndVGri
Advanced Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Option Explicit
Private Keys As Collection
'Функция получить номер строки перового вхождения
'Аргументы: ключ и номер строки
Private Function FirstEntry(ByVal Key As String, ByVal Index As Long) As Long
On Error GoTo errHandle
Key = UCase$(Key) 'преобразовать (фиг его знает как сравниваются по регистру)
Keys.Add Index, Key 'добавить ключ и номер строки
FirstEntry = -1 'если ключ уникален, то вернуть -1, иначе ошибка
Exit Function
errHandle:
'если ключ не уникален, то вернуть номер строки первого вхождения
FirstEntry = Keys.Item(Key)
End Function
'Выборка уникальных и повторяющихся записей
'Данные должны быть с 1 столбца с первой строки без заголовков
'Алгоритм:
'1 создание столбца с данными уникальности (0 иникальна, >0 - номер строки первого вхождения)
'2 выборка и копирование автофильтром уникальных на новый лист новой рабочей книги
'3 выборка и копирование автофильтром повторяющихся на новый лист созданной рабочей книги
' дополнительно на лист копируется столбец, содержащий номера строк первого вхождения
'4 удаление вспомогательной строки и столбца
Public Sub Test2()
Dim LastCol As Long, i As Long, RowCount As Long, id As Long
Dim heads() As String, arrKey As Variant
Dim Status() As Long, wksSheet As Worksheet
Dim resSheet As Worksheet, resBook As Workbook
Set wksSheet = ActiveSheet 'ссылка на лист данных
Set Keys = New Collection 'создать коллекцию уникальных значений и значений первых вхождений
RowCount = wksSheet.UsedRange.Rows.Count 'определить число строк таблицы данных
'получить данные ключевых столбцов
arrKey = wksSheet.Range(wksSheet.Cells(1, 5), wksSheet.Cells(RowCount, 8)).Value
ReDim Status(1 To RowCount, 1 To 1) 'создать массив определения уникальности
For i = 1 To RowCount 'цикл по данным массива ключевых столбцов
'получить индекс первого вхождения значений ключевых полей
id = FirstEntry(CStr(arrKey(i, 1)) & CStr(arrKey(i, 2)) & CStr(arrKey(i, 3)) & CStr(arrKey(i, 4)), i)
If id > 0 Then 'если такое значение ключевых полей существует
'то пишем номер строки первого вхождения в массив уникальности
Status(i, 1) = id: Status(id, 1) = id
End If
Next i
If Keys.Count < RowCount Then 'если есть повторяющиеся записи
'получить номер последнего столбца + 1 (для вставки данных массива уникальности)
LastCol = wksSheet.UsedRange.Columns.Count + 1
ReDim heads(1 To 1, 1 To LastCol) 'создать массив заголовков столбцов для автофильтра
For i = 1 To LastCol 'заполнить массив заголовков именами стобцов
heads(1, i) = "Cols" & CStr(i)
Next i
'вставить строку для имён столбцов
wksSheet.Rows(1).Insert Shift:=XlInsertShiftDirection.xlShiftDown
'записать имена столбцов в первую строку листа
wksSheet.Range(wksSheet.Cells(1, 1), wksSheet.Cells(1, LastCol)).Value = heads
'записать значения массива уникальности
wksSheet.Range(wksSheet.Cells(2, LastCol), wksSheet.Cells(RowCount + 1, LastCol)).Value = Status
'применить автофильтр для выборки не уникальных значений
wksSheet.UsedRange.AutoFilter LastCol, ">0"
'создать книгу результатов и лист дубликатов
Set resBook = Workbooks.Add()
Set resSheet = resBook.Worksheets.Add()
resSheet.Name = "Дубликаты"
'скопировать отфильтрованные данные
wksSheet.Range(wksSheet.Cells(2, 1), wksSheet.Cells(RowCount + 1, LastCol)).Copy
resSheet.PasteSpecial XlPasteType.xlPasteColumnWidths
resSheet.Paste
'отсортировать записи
resSheet.Sort.SortFields.Clear
id = resSheet.UsedRange.Rows.Count
resSheet.Sort.SortFields.Add resSheet.Range(resSheet.Cells(1, 5), resSheet.Cells(id, 5)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
resSheet.Sort.SortFields.Add resSheet.Range(resSheet.Cells(1, 6), resSheet.Cells(id, 6)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
resSheet.Sort.SortFields.Add resSheet.Range(resSheet.Cells(1, 7), resSheet.Cells(id, 7)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
resSheet.Sort.SortFields.Add resSheet.Range(resSheet.Cells(1, 8), resSheet.Cells(id, 8)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With resSheet.Sort
.SetRange resSheet.UsedRange
.Header = XlYesNoGuess.xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'применить автофильтр для выборки уникальных значений
wksSheet.UsedRange.AutoFilter LastCol, "0"
'создать лист для уникальных значений
Set resSheet = resBook.Worksheets.Add()
resSheet.Name = "Уникальные"
'скопировать отфильтрованные данные
wksSheet.Range(wksSheet.Cells(2, 1), wksSheet.Cells(RowCount + 1, LastCol - 1)).Copy
resSheet.PasteSpecial XlPasteType.xlPasteColumnWidths
resSheet.Paste
'убрать автофильтр
wksSheet.UsedRange.AutoFilter
'удалить вспомогательную строку и столбец
wksSheet.Rows(1).Delete XlDeleteShiftDirection.xlShiftUp
wksSheet.Columns(LastCol).Delete
End If
End Sub
|
Всего записей: 750 | Зарегистр. 14-12-2005 | Отправлено: 05:05 21-09-2011 | Исправлено: AndVGri, 05:07 21-09-2011 |
|
