На листе имеется соответствие текста/числа номеру телефона. Если в столбце B есть дубли телефонных номеров. Каждому номеру соответствует в столбце A какое-л. значение. Необходимо разнести все дубли (по столбцу "B") по отдельным листам (строчку вырезать и перенести на отдельный лист), чтобы на каждом листе книги небыло дубликатов в столбце B.
Пока что данных немного и можно сделать вручную. Но предвидится большое кол-во данных подобного рода и дубликатов соответственно (т.е. если будут дублироваться тысячи разных номеров (максимум три дубля на номер) - не должно быть дублей на каждом листе книги. Создаются отдельные листы, дубли сохраняются переносом на другие листы, до тех пор, пока ни в одном листе книги не останется дублирующихся записей). Надеюсь, сумел донести... Т.е. оставить все данные, но сделать так, чтобы не дублировались... А это возможно только разнесением по столбцам или листам, листы удобнее. Раз максимум три дубля - значит всего три листа будет.
На листе имеется соответствие текста/числа номеру телефона. Если в столбце B есть дубли телефонных номеров. Каждому номеру соответствует в столбце A какое-л. значение. Необходимо разнести все дубли (по столбцу "B") по отдельным листам (строчку вырезать и перенести на отдельный лист), чтобы на каждом листе книги небыло дубликатов в столбце B.
Пока что данных немного и можно сделать вручную. Но предвидится большое кол-во данных подобного рода и дубликатов соответственно (т.е. если будут дублироваться тысячи разных номеров (максимум три дубля на номер) - не должно быть дублей на каждом листе книги. Создаются отдельные листы, дубли сохраняются переносом на другие листы, до тех пор, пока ни в одном листе книги не останется дублирующихся записей). Надеюсь, сумел донести... Т.е. оставить все данные, но сделать так, чтобы не дублировались... А это возможно только разнесением по столбцам или листам, листы удобнее. Раз максимум три дубля - значит всего три листа будет.w00t
Sub tt() Dim a(), i&, ii&, x&, t$, el, elel Dim bb&, cc&, dd&, lShNewWBCount&
With Application .ScreenUpdating = False lShNewWBCount = .SheetsInNewWorkbook .SheetsInNewWorkbook = 3 End With
'взяли данные a = [a1].CurrentRegion.Columns(1).Resize(, 2).Value ReDim b(1 To UBound(a), 1 To 2) ReDim c(1 To UBound(a), 1 To 2) ReDim d(1 To UBound(a), 1 To 2)
'создали словарь, собрали уникальные с номерами строк With CreateObject("Scripting.Dictionary") .comparemode = 1 'текстовое сравнение For i = 1 To UBound(a) 'цикл по данным t = a(i, 2) 'критерий, тут бы trim() ещё может нужен... ' если нет в словаре, добавляем с коллекцией If Not .exists(t) Then .Add t, New Collection .Item(t).Add i 'в коллекцию критерия добавляем номер строки 'End If Next
'перебор словаря/коллекций For Each el In .keys 'перебор ключей ii = 0 'обнуляем счётчик его строк For Each elel In .Item(el) 'цикл по коллекции ключа ii = ii + 1 'счётчик строк выгружаемого массива Select Case ii Case 1 bb = bb + 1 'цикл по строке, полученной из коллекции, копирование данных For x = 1 To 2: b(bb, x) = a(elel, x): Next Case 2 cc = cc + 1 'цикл по строке, полученной из коллекции, копирование данных For x = 1 To 2: c(cc, x) = a(elel, x): Next Case 3 dd = dd + 1 'цикл по строке, полученной из коллекции, копирование данных For x = 1 To 2: d(dd, x) = a(elel, x): Next End Select Next Next
With Workbooks.Add() 'создаём книгу .Sheets(1).Cells(1).Resize(bb, 2) = b 'выгружаем массив .Sheets(2).Cells(1).Resize(cc, 2) = c 'выгружаем массив .Sheets(3).Cells(1).Resize(dd, 2) = d 'выгружаем массив End With
End With
With Application .SheetsInNewWorkbook = lShNewWBCount .ScreenUpdating = True End With
End Sub
[/vba]
Точно 3? Ну смотрите... [vba]
Код
Option Explicit
Sub tt() Dim a(), i&, ii&, x&, t$, el, elel Dim bb&, cc&, dd&, lShNewWBCount&
With Application .ScreenUpdating = False lShNewWBCount = .SheetsInNewWorkbook .SheetsInNewWorkbook = 3 End With
'взяли данные a = [a1].CurrentRegion.Columns(1).Resize(, 2).Value ReDim b(1 To UBound(a), 1 To 2) ReDim c(1 To UBound(a), 1 To 2) ReDim d(1 To UBound(a), 1 To 2)
'создали словарь, собрали уникальные с номерами строк With CreateObject("Scripting.Dictionary") .comparemode = 1 'текстовое сравнение For i = 1 To UBound(a) 'цикл по данным t = a(i, 2) 'критерий, тут бы trim() ещё может нужен... ' если нет в словаре, добавляем с коллекцией If Not .exists(t) Then .Add t, New Collection .Item(t).Add i 'в коллекцию критерия добавляем номер строки 'End If Next
'перебор словаря/коллекций For Each el In .keys 'перебор ключей ii = 0 'обнуляем счётчик его строк For Each elel In .Item(el) 'цикл по коллекции ключа ii = ii + 1 'счётчик строк выгружаемого массива Select Case ii Case 1 bb = bb + 1 'цикл по строке, полученной из коллекции, копирование данных For x = 1 To 2: b(bb, x) = a(elel, x): Next Case 2 cc = cc + 1 'цикл по строке, полученной из коллекции, копирование данных For x = 1 To 2: c(cc, x) = a(elel, x): Next Case 3 dd = dd + 1 'цикл по строке, полученной из коллекции, копирование данных For x = 1 To 2: d(dd, x) = a(elel, x): Next End Select Next Next
With Workbooks.Add() 'создаём книгу .Sheets(1).Cells(1).Resize(bb, 2) = b 'выгружаем массив .Sheets(2).Cells(1).Resize(cc, 2) = c 'выгружаем массив .Sheets(3).Cells(1).Resize(dd, 2) = d 'выгружаем массив End With
End With
With Application .SheetsInNewWorkbook = lShNewWBCount .ScreenUpdating = True End With
Ну да, ведь работает Для подстраховки ещё можно добавить case else с предупреждением, что где-то что-то повторяется больше предусмотренного. И именно что и сколько.
Вообще-то конечно если заранее количество непрогнозируемое и возможно большое - то код нужно писать иначе, но для 3-х или 6-ти штук можно и так... Но памяти временно съест много - массив данных и 3 (или уже 6) таких же массивов куда отбираем.
Ну да, ведь работает Для подстраховки ещё можно добавить case else с предупреждением, что где-то что-то повторяется больше предусмотренного. И именно что и сколько.
Вообще-то конечно если заранее количество непрогнозируемое и возможно большое - то код нужно писать иначе, но для 3-х или 6-ти штук можно и так... Но памяти временно съест много - массив данных и 3 (или уже 6) таких же массивов куда отбираем.Hugo