Здравствуйте. Имеется таблица с большим количеством строк.Нужен макрос, который находит все дубли в таблице (по полю СНИЛС) и копирует всю строку дубликата на отдельный лист (на первоначальном листе ничего с ними не делает.) Файл выкладываю "укороченный", в оригинале больше строк....
Здравствуйте. Имеется таблица с большим количеством строк.Нужен макрос, который находит все дубли в таблице (по полю СНИЛС) и копирует всю строку дубликата на отдельный лист (на первоначальном листе ничего с ними не делает.) Файл выкладываю "укороченный", в оригинале больше строк....wild_cat80
Sub u_429() Application.ScreenUpdating = False x = Sheets(2).Cells(Rows.Count, "a").End(xlUp).Row If x > 1 Then Sheets(2).Range("a2:l" & x).Clear a = Cells(Rows.Count, "i").End(xlUp).Row For Each b In Range("i5:i" & a) c = b.Row d = Application.Match(b, Range("i4:i" & c - 1), 0) e = Application.Match(b, Range("i" & c + 1 & ":i" & a + 1), 0) f = IsNumeric(d) g = IsNumeric(e) If f Or g Then h = Sheets(2).Cells(Rows.Count, "a").End(xlUp).Row + 1 Range("a" & c & ":l" & c).Copy Sheets(2).Range("a" & h) End If Next 'если нужна сортировка--------------------------------------------------- If h > 2 Then Sheets(2).Range("a2:l" & h).Sort key1:=Sheets(2).Range("i2:i" & h), _ order1:=xlAscending, Header:=xlNo End If '------------------------------------------------------------------------ Application.ScreenUpdating = True End Sub
[/vba]
[vba]
Код
Sub u_429() Application.ScreenUpdating = False x = Sheets(2).Cells(Rows.Count, "a").End(xlUp).Row If x > 1 Then Sheets(2).Range("a2:l" & x).Clear a = Cells(Rows.Count, "i").End(xlUp).Row For Each b In Range("i5:i" & a) c = b.Row d = Application.Match(b, Range("i4:i" & c - 1), 0) e = Application.Match(b, Range("i" & c + 1 & ":i" & a + 1), 0) f = IsNumeric(d) g = IsNumeric(e) If f Or g Then h = Sheets(2).Cells(Rows.Count, "a").End(xlUp).Row + 1 Range("a" & c & ":l" & c).Copy Sheets(2).Range("a" & h) End If Next 'если нужна сортировка--------------------------------------------------- If h > 2 Then Sheets(2).Range("a2:l" & h).Sort key1:=Sheets(2).Range("i2:i" & h), _ order1:=xlAscending, Header:=xlNo End If '------------------------------------------------------------------------ Application.ScreenUpdating = True End Sub
Sub tt() With ActiveSheet .Copy After:=Sheets(.Index) End With Application.ScreenUpdating = 0 With ActiveSheet asn_ = .Cells.Find(What:="СНИЛС").Address With .Range(asn_) r0_ = .Row csn_ = .Column With .CurrentRegion nr_ = .Rows.Count nc_ = .Columns.Count .AutoFilter With .Columns(csn_) .FormatConditions.AddUniqueValues With .FormatConditions(1) .DupeUnique = xlDuplicate .Interior.Color = 3 End With End With .AutoFilter Field:=csn_, Operator:=xlFilterNoFill .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete .FormatConditions.Delete .AutoFilter .RemoveDuplicates Columns:=csn_, Header:=xlYes End With End With End With Application.ScreenUpdating = 1 End Sub
[/vba]
Еще вариант [vba]
Код
Sub tt() With ActiveSheet .Copy After:=Sheets(.Index) End With Application.ScreenUpdating = 0 With ActiveSheet asn_ = .Cells.Find(What:="СНИЛС").Address With .Range(asn_) r0_ = .Row csn_ = .Column With .CurrentRegion nr_ = .Rows.Count nc_ = .Columns.Count .AutoFilter With .Columns(csn_) .FormatConditions.AddUniqueValues With .FormatConditions(1) .DupeUnique = xlDuplicate .Interior.Color = 3 End With End With .AutoFilter Field:=csn_, Operator:=xlFilterNoFill .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete .FormatConditions.Delete .AutoFilter .RemoveDuplicates Columns:=csn_, Header:=xlYes End With End With End With Application.ScreenUpdating = 1 End Sub