#excel #vba
#excel #vba
Вопрос:
У меня много сотрудников в списке, показывающем, какие курсы они прошли. Столбец A — это их идентификатор клиента, столбец M — курс, который они закончили.
Как мне удалить строку, если для каждого идентификатора существует дублирующаяся запись курса, поскольку некоторые сотрудники будут использовать одно и то же название курса.
Комментарии:
1. Создайте новый столбец, содержащий комбинацию CustomerID CourseID, затем удалите дубликаты.
Ответ №1:
Используйте функцию удаления дубликатов в Excel, просто выделите 2 столбца, из значений которых вы хотите удалить дубликаты. Краткий пример ниже:
Затем выберите в диалоговом окне 2 столбца, которые вы хотите проверить на наличие повторяющихся значений (обязательно снимите флажки со всех столбцов, которые не относятся к делу).
Мой пример вывода:
Ответ №2:
Удалить дублирующиеся строки, т.е. Скрыть или удалить
- В 1-м подразделе показано, как использовать 2-й, основной подраздел (
removeDuplicateRows
). - Остальные вспомогательные модули вызываются из основного вспомогательного модуля (также необходимо).
- Только после завершения тестирования переходите от скрытия к удалению.
Код
Option Explicit
Sub testRemoveDuplicateRows()
Const wsName As String = "Sheet1"
Const LastRowColumnID As Variant = "A" ' e.g. 1 or "A"
Const FirstRow As Long = 2
Dim ColumnIDs As Variant: ColumnIDs = Array(1, "M")
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Hide duplicate rows.
removeDuplicateRows ws, ColumnIDs, LastRowColumnID, FirstRow, True
' Delete duplicate rows.
'removeDuplicateRows ws, ColumnIDs, LastRowColumnID, FirstRow
End Sub
Sub removeDuplicateRows(Sheet As Worksheet, _
ColumnIDs As Variant, _
Optional LastRowColumnID As Variant = 1, _
Optional FirstRow As Long = 1, _
Optional hideOnly As Boolean = False)
' Write values of columns to jagged array.
Dim Cols As Variant
getColumns Cols, Sheet, ColumnIDs, LastRowColumnID, FirstRow
' Join values of arrays in jagged array.
Dim Data As Variant: joinColumns Data, Cols
' Write duplicate row numbers to array.
Dim RowOffset As Long: RowOffset = FirstRow - 1 ' 1 = ubound(Data)
Dim DupeRows As Variant
collectDuplicateRows DupeRows, Data, RowOffset
' Hide or delete duplicate rows.
If hideOnly Then
hideRows Sheet, DupeRows
Else
deleteRows Sheet, DupeRows
End If
End Sub
Sub getColumns(ByRef Data As Variant, _
Sheet As Worksheet, _
ColumnIDs As Variant, _
Optional LastRowColumnID As Variant = 1, _
Optional FirstRow As Long = 1)
Dim ubc As Long: ubc = UBound(ColumnIDs)
If ubc = -1 Then Exit Sub
Dim rng As Range: getColumnRange rng, Sheet, LastRowColumnID, FirstRow
If rng Is Nothing Then Exit Sub
ReDim Data(ubc): getColumnFromColumnRange Data(0), rng
If ubc > 0 Then GoSub getRemainingColumns
Exit Sub
getRemainingColumns:
Dim j As Long
For j = 1 To ubc
getColumnFromColumnRange Data(j), _
rng.Offset(, Sheet.Columns(ColumnIDs(j)).Column - rng.Column)
Next j
Return
End Sub
Sub getColumnRange(ByRef ColumnRange As Range, _
Sheet As Worksheet, _
Optional ColumnID As Variant = 1, _
Optional FirstRow As Long = 1)
Set ColumnRange = Nothing
Dim rng As Range
Set rng = Sheet.Columns(ColumnID).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
Set ColumnRange = Sheet.Range(Sheet.Cells(FirstRow, ColumnID), rng)
End Sub
Sub getColumnFromColumnRange(ByRef Data As Variant, _
ColumnRange As Range)
If ColumnRange Is Nothing Then Exit Sub
If ColumnRange.Cells.Count > 1 Then
Data = ColumnRange.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = ColumnRange.Value
End If
End Sub
Sub joinColumns(ByRef Data As Variant, _
ColumnsArray As Variant, _
Optional Delimiter As String = "|||")
Data = ColumnsArray(0)
If UBound(ColumnsArray) = 0 Then Exit Sub
Dim ubr As Long: ubr = UBound(Data)
Dim j As Long, i As Long
For j = 1 To UBound(ColumnsArray)
For i = 1 To ubr
Data(i, 1) = Data(i, 1) amp; Delimiter amp; ColumnsArray(j)(i, 1)
Next i
Next j
End Sub
Sub collectDuplicateRows(ByRef DupeRows As Variant, _
Data As Variant, _
Optional RowOffset As Long = 0, _
Optional DupeRowsFirstIndex As Long = 0)
Dim ub As Long: ub = UBound(Data)
If ub < 2 Then Exit Sub
Dim i As Long, k As Long, m As Long: m = DupeRowsFirstIndex - 1
ReDim DupeRows(DupeRowsFirstIndex To ub DupeRowsFirstIndex - 2)
For i = 1 To ub - 1
For k = i 1 To ub
If Data(k, 1) = Data(i, 1) Then
m = m 1
DupeRows(m) = k RowOffset
Exit For
End If
Next k
Next i
If m > DupeRowsFirstIndex - 1 Then
ReDim Preserve DupeRows(DupeRowsFirstIndex To m)
Else
DupeRows = Empty
End If
End Sub
Sub deleteRows(Sheet As Worksheet, _
RowNumbers As Variant)
Dim rng As Range: Set rng = Sheet.Rows(RowNumbers(LBound(RowNumbers)))
If UBound(RowNumbers) > LBound(RowNumbers) Then GoSub collectRemainingRows
If Not rng Is Nothing Then rng.EntireRow.Delete
Exit Sub
collectRemainingRows:
Dim j As Long
For j = LBound(RowNumbers) 1 To UBound(RowNumbers)
Set rng = Union(rng, Sheet.Rows(RowNumbers(j)))
Next j
Return
End Sub
Sub hideRows(Sheet As Worksheet, _
RowNumbers As Variant)
Dim rng As Range: Set rng = Sheet.Rows(RowNumbers(LBound(RowNumbers)))
If UBound(RowNumbers) > LBound(RowNumbers) Then GoSub collectRemainingRows
If Not rng Is Nothing Then rng.EntireRow.Hidden = True
Exit Sub
collectRemainingRows:
Dim j As Long
For j = LBound(RowNumbers) 1 To UBound(RowNumbers)
Set rng = Union(rng, Sheet.Rows(RowNumbers(j)))
Next j
Return
End Sub