VBA：将Excel表的重复列值的第一行和最后一行保持

Question

我有一个带有20k行的Excel工作表：

Header1	Header2
1	P
2	P
2	P 3 P
4	Q
5	R
6	R
7	R 7 R
8	R
9	S
10	S

我想要一个VBA代码来删除包含重复的行，但保持重复的第一行。结果应该是这样的：

header1	header2
1	p
3	p
4	q
5	r
8	r
9	s
10	s

我修改了以下代码在这里选择包含列Header2中的重复项的范围。

Sub Delete_Dups_Keep_Last_v2()
 Dim SelRng As Range
 Dim Cell_in_Rng As Range
 Dim RngToDelete As Range
 Dim SelLastRow As Long
 
    Application.DisplayAlerts = False
    Set SelRng = Application.InputBox("Select cells", Type:=8)
    On Error GoTo 0
    Application.DisplayAlerts = True
 
    SelLastRow = SelRng.Rows.Count + SelRng.Row - 1
    For Each Cell_in_Rng In SelRng
        
        If Cell_in_Rng.Row < SelLastRow Then
            If Cell_in_Rng.Row > SelRng.Row Then
                If Not Cell_in_Rng.Offset(1, 0).Resize(SelLastRow - Cell_in_Rng.Row).Find(What:=Cell_in_Rng.Value, Lookat:=xlWhole) Is Nothing Then
                    'this value exists again in the range
                    If RngToDelete Is Nothing Then
                        Set RngToDelete = Cell_in_Rng
                    Else
                        Set RngToDelete = Application.Union(RngToDelete, Cell_in_Rng)
                    End If
                End If
            End If
        End If
        
    Next Cell_in_Rng
 
    If Not RngToDelete Is Nothing Then RngToDelete.EntireRow.Delete

End Sub

另一个代码找到在这里=“不确定如何标记某人”> Ash 使用字典自动选择手动选择和速度，但无法产生所需的结果。

Sub keepFirstAndLast()
  Dim toDelete As Range: Set toDelete = Sheet1.Rows(999999) '(to not start with a null range)
  Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

  Dim a As Range
  For Each a In Sheet1.Range("B2", Sheet1.Range("B999999").End(xlUp))
    If Not dict.Exists(a.Value2) Then
      dict(a.Value2) = 0 ' first appearence, dont save the row
    Else
      ' if last observed occurrence was a duplicate, add it to deleted range
      If dict(a.Value2) > 0 Then Set toDelete = Union(toDelete, Sheet1.Rows(dict(a.Value2)))
      dict(a.Value2) = a.row ' not first appearence, save the row for eventual deletion
    End If
  Next
  toDelete.Delete
End Sub

Answer 1

简单解决方案：

Sub KeepFirstLast()

Application.ScreenUpdating = False

Dim lastRow As Long
lastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Dim i As Long
Dim x As Long
Dim currentValue As String

For i = lastRow To 2 Step -1
    If i = 2 Then
        Application.ScreenUpdating = True
        Exit For
    End If
    currentValue = Sheets(1).Cells(i, 2).Value
    x = i - 1
    Do While Sheets(1).Cells(x, 2).Value = currentValue And Sheets(1).Cells(x - 1, 2).Value = currentValue
        Sheets(1).Rows(x).Delete
        x = x - 1
    Loop
    i = x + 1
Next i


Application.ScreenUpdating = True

End Sub

Answer 2

您可能会从specialcells中受益，可以根据公式选择这些行：

Sub test()
Dim LR As Long 'last row
Dim LC As Long 'last column
Dim SR As Long 'starting row
Dim rng As Range

Set rng = Range("A1") 'change this to TOP LEFT CELL OF YOUR DATA

SR = rng.Row
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
LC = Cells(1, Columns.Count).End(xlToLeft).Column 'last column used

'we add new column with formula to delete
With Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1))
    .FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
    .SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete
End With

'clear formula
LR = rng.CurrentRegion.Cells(rng.CurrentRegion.Rows.Count, 1).Row
Range(Cells(SR + 1, LC + 1), Cells(LR, LC + 1)).Clear

Set rng = Nothing

End Sub

[！[Enter Image Description在此处] [1]] [1] [1]

棘手的部分在这里：

.FormulaR1C1 = "=IF(OR(RC[-1]<>R[-1]C[-1],RC[-1]<>R[1]C[-1]),""x"",0)"
.SpecialCells(xlCellTypeFormulas, 1).EntireRow.Delete

第一行将创建，如果（OR）公式以检查该行是否必须删除。它将返回x如果不是，else 0

第二行只有在包含一个数字时才会删除整个行（零）
[1]： https://i.sstatic.net/ulhti.gif

Answer 3

这也可以使用电源查询来完成，该电源查询可在Windows Excel 2010+和Excel 365（Windows或Mac）中使用，

以使用电源查询

• 选择数据表中的一些单元格
• data =＆gt;获取＆amp; transform =＆gt;从表/范围或从表格中
• 打开时：home =＆gt;高级编辑器
• 在第2行中的表格名称
• 粘贴下面的M代码，以代替您看到的
• 第2行中的表名称回到最初生成的内容。
• 阅读评论并探索应用步骤以了解算法

m代码

let

//change next line to your actual table name in your worksheet
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"header1", Int64.Type}, {"header2", type text}}),

//Group by header2
// then return the first and last table rows if there is more than a single row
    #"Grouped Rows" = Table.Group(#"Changed Type", {"header2"}, {
        {"header1", each if Table.RowCount(_) = 1 then _ 
            else Table.FromRecords({Table.First(_),Table.Last(_)}), 
                    type table[header1=Int64.Type, header2=text]}
        }),

//expand the subtables and set the column order
    #"Expanded header1" = Table.ExpandTableColumn(#"Grouped Rows", "header1", {"header1"}),
    #"Reordered Columns" = Table.ReorderColumns(#"Expanded header1",{"header1", "header2"})
in
    #"Reordered Columns"

Answer 4

在排序范围内保持第一和最后

Option Explicit

Sub DeleteNotFirstNorLast()
    Const ProcName As String = "DeleteNotFirstNorLast"
    Dim RowsDeleted As Boolean ' to inform
    On Error GoTo ClearError ' enable error trapping
    
    ' Constants (adjust!)
    Const FirstCellAddress As String = "A1"
    Const CriteriaColumnIndex As Long = 2
    Const Criteria As String = "#$%"
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Application.ScreenUpdating = False
    
    ' Turn off AutoFilter.
    If ws.AutoFilterMode Then ws.AutoFilterMode = False 
    
    ' Reference the table range.
    Dim trg As Range: Set trg = RefCurrentRegion(ws.Range(FirstCellAddress))
    
    ' Write an ascending integer sequence adjacent to the right
    ' of the table range.
    AppendColumnOfAscendingIntegers trg
    
    ' Include this helper column to the table range.
    Set trg = trg.Resize(, trg.Columns.Count + 1)
    
    ' Reference the criteria column range.
    Dim crg As Range: Set crg = trg.Columns(CriteriaColumnIndex)
    
    ' It is assumed that the criteria column is already sorted favorably.
    ' If not, you could do something like the following:
    
    ' Sort the table range by the criteria column ascending.
    'trg.Sort crg, xlAscending, , , , , , xlYes
    
    ' Write the data rows (no headers) count to a variable.
    Dim drCount As Long: drCount = trg.Rows.Count - 1
    
    ' Reference the criteria column data range (headers excluded).
    Dim cdrg As Range: Set cdrg = crg.Resize(drCount).Offset(1)
    
    ' Write the values from the criteria column data range to an array.
    Dim cData As Variant: cData = GetRange(cdrg)
    
    ' Replace the unwanted values in the array with the criteria.
    KeepFirstAndLastInColumn cData
    
    ' Write the (modified) values from the array back to the range.
    cdrg.Value = cData
    
    ' Reference the table data range (no headers).
    Dim tdrg As Range: Set tdrg = trg.Resize(drCount).Offset(1)
    
    ' Filter the table range in the criteria column by the criteria.
    trg.AutoFilter CriteriaColumnIndex, Criteria
    
    ' Attempt to reference the table data visible (filtered) range.
    Dim tdvrg As Range
    On Error Resume Next ' defer error trapping
        Set tdvrg = tdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo ClearError ' re-enable error trapping
    
    ' Remove the filter.
    ws.AutoFilterMode = False
    
    ' Attempt to delete the table data visible range.
    If Not tdvrg Is Nothing Then
        tdvrg.Delete xlShiftUp
        RowsDeleted = True
    End If
    
    ' Reference the helper column.
    Dim hrg As Range: Set hrg = trg.Columns(trg.Columns.Count)
    
    ' Sort the table range by the helper column ascending.
    trg.Sort hrg, xlAscending, , , , , , xlYes
    
    ' Clear the helper column.
    hrg.Clear
    
SafeExit:
    Application.ScreenUpdating = True ' to see any changes while reading message
    
    ' Inform.
    If RowsDeleted Then
        MsgBox "Rows deleted.", vbInformation, ProcName
    Else
        MsgBox "Nothing deleted.", vbExclamation, ProcName
    End If

    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume SafeExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range starting with the first cell
'               of a range and ending with the last cell of the first cell's
'               Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefCurrentRegion"
    On Error GoTo ClearError

    If FirstCell Is Nothing Then Exit Function
    With FirstCell.Cells(1).CurrentRegion
        Set RefCurrentRegion = FirstCell.Resize(.Row + .Rows.Count _
            - FirstCell.Row, .Column + .Columns.Count - FirstCell.Column)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes an ascending integer sequence adjacent to the right
'               of a range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub AppendColumnOfAscendingIntegers( _
        ByVal trg As Range, _
        Optional ByVal FirstInteger As Long = 1)
    Const ProcName As String = "AppendColumnOfAscendingIntegers"
    On Error GoTo ClearError
    
    With trg
        With .Resize(, 1).Offset(, .Columns.Count)
            .Value = .Worksheet.Evaluate("ROW(" & CStr(FirstInteger) & ":" _
                & CStr(FirstInteger + .Rows.Count - 1) & ")")
        End With
    End With

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('trg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal trg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If trg.Rows.Count + trg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = trg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = trg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      In the first column of a 2D one-based array of sorted values,
'               keeps the first and last occurrence of each value and replaces
'               the remaining occurrences with a string.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub KeepFirstAndLastInColumn( _
        ByRef cData As Variant, _
        Optional ByVal Criteria As String = "#$%")
    Const ProcName As String = "KeepFirstAndLastInColumn"
    On Error GoTo ClearError

    Dim OldString As String: OldString = CStr(cData(1, 1))
    
    Dim r As Long
    Dim cr As Long
    Dim FirstRow As Long
    Dim NewString As String
    
    For r = 2 To UBound(cData, 1)
        NewString = CStr(cData(r, 1))
        If NewString = OldString Then
            If FirstRow = 0 Then
                FirstRow = r
            End If
        Else
            If FirstRow > 0 Then
                For cr = FirstRow To r - 2
                    cData(cr, 1) = Criteria
                Next cr
                FirstRow = 0
            End If
            OldString = NewString
        End If
    Next r

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub