Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 5.00/5: Рейтинг темы: голосов - 5, средняя оценка - 5.00
Siserian
0 / 0 / 0
Регистрация: 15.03.2019
Сообщений: 25
1

вырезать дубликаты

10.10.2019, 14:21. Просмотров 1018. Ответов 11
Метки нет (Все метки)

Здравствуйте, подскажите пожалуйста, есть нужда в сборе дубликатов, таблица следующая
111-111-111 22 ываыва ываыва ываыа фывфвсссссс
222-222-222 33 ываыва ываыва ываыа фывфвсссссс
111-111-111 22 ываыва ываыва ываыа фывфвсссссс
222-222-222 33 ываыва ываыва ываыа фывфвсссссс
333-333-333 44 мясясяс мчсмч сячсф фывфвсссссс
ну и таких похожих записей 57000, из них приблизительно 1/3 дубли, их нужно вырезать на лист Sheet2

с вырезанием я разобрался, а вот с поиском чот всё плохо...


Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
Sub FindAndExecute()
 
 
For i = 1 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
variableI = 0
 With Worksheets(1).Range("A1:A" + CStr(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row))
 
    Dim C As Range
 
    Set C = .Find(Sheets("Sheet 1").Cells(i, 2), LookIn:=xlValues)
 
    If Not C Is Nothing Then
 
        Dim FirstAddress As String, Rslt As String
 
        FirstAddress = C.Address
 
        Do
 
If Sheets("Sheet 1").Cells(C.Row, 2) = "" Then
Else
If C.Row = i Then
 
Else
variableI = variableI + 1
           Rslt = Rslt & C.Address & ","
            Sheets("Sheet 1").Select
    Rows(CStr(C.Row) + ":" + CStr(C.Row)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Rows("1:1").Select
    ActiveSheet.Paste
   ' MsgBox "find " + Sheets("Sheet2").Cells(i, 2)
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Sheets("Sheet 1").Select
           
'MsgBox C.Row
End If
End If
 
 
            Set C = .FindNext(C)
 
        Loop While C.Address <> FirstAddress
 
       
 
        End If
 
        End With
        Next i
End Sub
0
Лучшие ответы (1)
QA
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
10.10.2019, 14:21
Ответы с готовыми решениями:

Удалить дубликаты
Уважаемые знатоки VBA. Каждый из вас наверняка встречался со следующей задачей: есть столбец с...

Дубликаты переменных
В Turbo Pascal был такой фокус: Var q1 : ^Double q2 : ^Double Begin new(q1); q2 :=...

Выделить дубликаты цветом
Суть в том, что есть 1 длинный столбец с текстовыми данными, некоторые из которых повторятются по...

Удалить строки, содержащие дубликаты
В Эксель 6 колонок с номерами, выглядит это так А В С Д Е Ф 1 2 2 3 5 6 1 2 3 4 4 7 ...

Как удалить дубликаты из ListBox?
Нужно было написать событие, удаляющее из списка дубликаты. Сижу уже несколько дней непролазно за...

11
SoftIce
es geht mir gut
11121 / 4532 / 1144
Регистрация: 27.07.2011
Сообщений: 11,132
Завершенные тесты: 1
10.10.2019, 15:05 2
Цитата Сообщение от Siserian Посмотреть сообщение
их нужно вырезать на лист Sheet2
Кого "их" ? Вы лучше номера строк скажите, которые нужно переместить на второй лист. И файл приложите.
0
art1289
41 / 33 / 8
Регистрация: 02.08.2019
Сообщений: 137
Записей в блоге: 3
10.10.2019, 15:27 3
Siserian, может проще уникальные вытащить ? и посчитать количество дублей формулой ?
0
Siserian
0 / 0 / 0
Регистрация: 15.03.2019
Сообщений: 25
10.10.2019, 15:27  [ТС] 4
Цитата Сообщение от SoftIce Посмотреть сообщение
Кого "их" ? Вы лучше номера строк скажите, которые нужно переместить на второй лист. И файл приложите.
https://dropmefiles.com/B5aaO
дубли ищем в столбце "B"
все данные находятся в Sheet 1 листе,
Sheet2 пустой лист, туда нужно вырезать и вставить все дубли.
0
10.10.2019, 15:27
SoftIce
es geht mir gut
11121 / 4532 / 1144
Регистрация: 27.07.2011
Сообщений: 11,132
Завершенные тесты: 1
10.10.2019, 15:34 5
Цитата Сообщение от Siserian Посмотреть сообщение
111-111-111 22 ываыва ываыва ываыа фывфвсссссс
222-222-222 33 ываыва ываыва ываыа фывфвсссссс
111-111-111 22 ываыва ываыва ываыа фывфвсссссс
222-222-222 33 ываыва ываыва ываыа фывфвсссссс
333-333-333 44 мясясяс мчсмч сячсф фывфвсссссс
Что здесь "дубли" в Вашем понимании.
0
Siserian
0 / 0 / 0
Регистрация: 15.03.2019
Сообщений: 25
10.10.2019, 15:38  [ТС] 6
111-111-111 22
111-111-111 22
222-222-222 33
222-222-222 33
проверяются данные на дубли только из колонки "B"
да и простите меня, я забыл сказать, нужно будет вырезать всю строку
т.е. на sheet2 должно быть

111-111-111 22 ываыва ываыва ываыа фывфвсссссс
111-111-111 22 ываыва ываыва ываыа фывфвсссссс
222-222-222 33 ываыва ываыва ываыа фывфвсссссс
222-222-222 33 ываыва ываыва ываыа фывфвсссссс
0
SoftIce
10.10.2019, 15:59
  #7

Не по теме:

Извините, пока недосуг

0
art1289
41 / 33 / 8
Регистрация: 02.08.2019
Сообщений: 137
Записей в блоге: 3
10.10.2019, 16:43 8
Siserian, попробуйте вместо поиска отсортировать данные, а потом уже легко можно скопировать данные на новый лист
0
SoftIce
es geht mir gut
11121 / 4532 / 1144
Регистрация: 27.07.2011
Сообщений: 11,132
Завершенные тесты: 1
10.10.2019, 16:56 9
Лучший ответ Сообщение было отмечено Siserian как решение

Решение

Вот
1
Вложения
Тип файла: rar test.rar (111.6 Кб, 3 просмотров)
Siserian
0 / 0 / 0
Регистрация: 15.03.2019
Сообщений: 25
10.10.2019, 17:10  [ТС] 10
Спасибо большое, вроде всё работает, так чисто узнать, я в коде своём хоть шел в правильном направлении?
0
SoftIce
es geht mir gut
11121 / 4532 / 1144
Регистрация: 27.07.2011
Сообщений: 11,132
Завершенные тесты: 1
10.10.2019, 17:21 11
Цитата Сообщение от Siserian Посмотреть сообщение
я в коде своём хоть шел в правильном направлении
Извините, не вникал.
Взглянул просто, увидел "Cells,Cells,Select,Select,Select,Select".... и сделал на массивах и словарях.
0
toiai
3171 / 927 / 214
Регистрация: 29.05.2010
Сообщений: 2,004
10.10.2019, 20:38 12
Как вариант:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Razdelenie()
    Dim shSrc As Worksheet, rCol1 As Range, c As Range
    Dim cl As New Collection
    Set shSrc = ActiveSheet
    With ActiveSheet.UsedRange.Columns(1)
        .Offset(, -1).FormulaR1C1 = "=IF(COUNTIF(R1C2:R" & .Cells.Count & "C2,RC[1])>1,2,1)"
        .Offset(, -1).Value = .Offset(, -1).Value
    End With
    Set rCol1 = shSrc.UsedRange.Columns("A:A")
    On Error Resume Next
    For Each c In rCol1.Cells
        cl.Add 0, CStr(c.Value)
        If Err Then
            Err.Clear
        Else
            shSrc.Copy After:=Sheets(Sheets.Count)
            ActiveSheet.Name = c
            ActiveSheet.Range(rCol1.Address).ColumnDifferences(c).EntireRow.Delete
            Columns(1) = Empty
            shSrc.Activate
        End If
    Next
    rCol1 = Empty
End Sub
0
10.10.2019, 20:38
Answers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
10.10.2019, 20:38

Удаление повторяющихся (дубликаты) значений. VBA
Добрый день Уважаемые форумчане, Хочу спросить у вас помощи, возможно ли каким-либо образом...

Как в excel убрать дубликаты записей?
необходимо из двух (трех и т.д.) таблиц сделать одну , а потом убрать повторяющиеся записи....

Найти и сложить дубликаты по нескольким колонкам, затем удалить
Здравствуйте уважаемые форумчане! Нужна помощь в правке макроса. Есть таблица: ...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
12
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2019, vBulletin Solutions, Inc.