Excel Macro. Удалить не повторяющиеся строки на основе столбца - PullRequest
Новая
       6

Excel Macro. Удалить не повторяющиеся строки на основе столбца

0 голосов
/ 31 января 2012

Попытка запустить макрос в Excel, чтобы удалить не дубликаты, чтобы легко проверить их на наличие ошибок.

Пройти через каждую ячейку в столбце «B», начиная с B2 (B1 - заголовок)

Во время выполнения, если текущая ячейка B имеет совпадение где-либо в столбце B - оставить его, если он уникален - удалить всю строку

Приведенный ниже код выполняется с противоречивыми результатами.

В поисках понимания 

Sub RemoveNonDupes()
 Selection.Copy
 Range("B2").Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 Range("B2:B5000").AdvancedFilter Action:= xlFilterInPlace,  CriteriaRange:= Range("B2"), Unique := True
 Range("B2:B5000").SpecialCells(xlCellTypeVisible).EntireRow.Delete
 ActiveSheet.showalldata
End Sub

Ответы [ 2 ]

1 голос
/ 31 января 2012

Не самый прямой маршрут, но вы можете вставить макрос между B и C. Затем выведите формулу в этот столбец, который считается.

Что-то вроде = countifs (B: B, B: B). Это даст вам счетчик того, сколько раз показывается запись, а затем вы можете установить для сценария Loop, удаляя любую строку, где это значение равно 1.

Что-то вроде 

Sub Duplicates()

Columns("B:B").Insert Shift:=xlToRight ' inserts a column after b

count = Sheet1.Range("B:B").Cells.SpecialCells(xlCellTypeConstants).count ' counts how many records you have

crange = "C1:C" & count ' this defines the range your formula's go in if your data doesn't start in b1, change the c1 above to match the row your data starts

Sheet1.Range(crange).Formula = "=countifs(B:B,B:B)"  ' This applies the same forumla to the range

ct=0
ct2=0  'This section will go cell by cell and delete the entire row if the count value is 1
Do While ct2 < Sheet1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
    For ct = 0 To Sheet1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
        If Sheet1.Range("C1").Offset(ct, 0).Value > 1 Then
            Sheet1.Range("C1").Offset(ct, 0).EntireRow.Delete
        End If

    Next
ct2 = ct2 + 1

Loop
Sheet1.Columns("B:B").EntireColumn.delete
end sub

Код не очень красивый, но он должен делать свою работу.

** Обновлен код для комментариев 

Sub Duplicates()

Columns("C:C").Insert Shift:=xlToRight ' inserts a column after b

count = Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count ' counts how many records you have

crange = "C1:C" & count ' this defines the range your formula's go in if your data doesn't start in b1, change the c1 above to match the row your data starts

Activesheet.Range(crange).Formula = "=countifs(B:B,B:B)"  ' This applies the same forumla to the range


ct=0
ct2=0  'This section will go cell by cell and delete the entire row if the count value is 1
'''''
Do While ct2 < Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
    For ct = 0 To Activesheet.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).count
        If Activesheet.Range("C1").Offset(ct, 0).Value = 1 Then
            Activesheet.Range("C1").Offset(ct, 0).EntireRow.Delete
        End If

    Next
ct2 = ct2 + 1

Loop
ActiveSheet.Columns("C:C").EntireColumn.delete  
end sub

Вы можете попробовать этот обновленный код, часть с циклом Do - это то, что будет удалять каждый столбец, я исправил его, чтобы удалить любую строку, где количество равно 1.
Исходя из того, что я понимаю, ваши данные должны быть в столбце B, а число должно быть в столбце C. Если это не так, обновите формулы, чтобы они соответствовали

0 голосов
/ 31 января 2012

Крис, чтобы изучить уникальные значения в заданном диапазоне данных, я предлагаю использовать функцию расширенного копирования Excel немного по-другому: 

Range("RangeWithDupes").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("TargetRange"), unique:=True

Операция предоставит вам список уникальных значений изRangeWithDupes находится в TargetRange.Затем вы можете использовать результирующий диапазон для манипулирования исходными данными разными способами.Надеюсь, это поможет.

...