本文于2023年6月21日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！
☆本期内容概要☆
工作表重复值处理模板代码
所有代码均在UserForm1里，大家可以把它直接拖到自己的表里，把自己的需要处理重复值的表改为“明细表”或者，把代码中的“明细表”替换成你的表名。
1、用户窗体启动代码：
Dim arrFields() '定义在所有模块外面的变量
Private Sub UserForm_Activate()
Dim iRow As Integer, iCol As Integer
Dim topPos As Integer
Sheets("明细表").Activate
With ActiveSheet
iRow = .UsedRange.Rows.Count
iCol = .UsedRange.Columns.Count
For i = 1 To iCol
If Cells(1, i) <> "" Then
ReDim Preserve arrFields(k)
arrFields(k) = Cells(1, i)
k = k + 1
End If
Next
End With
leftPos = Me.LbSelect.Left + 10 ' 复选框的左侧位置
topPos = Me.LbSelect.Top + Me.LbSelect.Height + 10 ' 复选框的顶部位置
For i = LBound(arrFields) To UBound(arrFields)
'在指定位置插入复选框
Me.Controls.Add "Forms.CheckBox.1", "CheckBox" & i
'设置复选框的位置和属性
With Me.Controls("CheckBox" & i)
.Left = leftPos
.Top = topPos
.Width = 40
.Height = 20
.Caption = arrFields(i)
.Value = False
End With
'更新位置
If (i + 1) Mod 4 = 0 Then
'换行
leftPos = Me.LbSelect.Left + 10
topPos = topPos + 20
Else
'同行下一个位置
leftPos = leftPos + 40
End If
Next
'Stop
End Sub
2、重复值标色代码：
Sub HighlightDuplicateRecords() '重复值标色
Dim ws As Worksheet
Dim lastRow As Long, lastColumn As Long
Dim colorIndex As Integer
Dim arr(), tbTitle(), arrRows()
Dim duplicateRows As String
Dim markCol As Integer
Dim arrKey() As String
ThisWorkbook.Activate
For i = LBound(arrFields) To UBound(arrFields)
If Me.Controls("CheckBox" & i) = True Then
ReDim Preserve arrKey(k)
arrKey(k) = i + 1
k = k + 1
End If
Next
If k = 0 Then
MsgBox "请至少选择一个科目！"
Exit Sub
End If
Set ws = ThisWorkbook.Sheets("明细表")
ws.Activate
lastRow = ws.UsedRange.Rows.Count
lastColumn = ws.UsedRange.Columns.Count
arr = ws.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Value
ws.Range(Cells(2, 1), Cells(lastRow, lastColumn)).Interior.Color = vbWhite
For i = 1 To lastColumn
If arr(1, i) = "是否重复" Then
t = i
End If
Next
If t > 0 Then
markCol = t
Else
markCol = lastColumn + 1
ws.Cells(1, markCol) = "是否重复"
End If
ws.Range(Cells(2, markCol), Cells(lastRow, markCol)).Clear
'标记重复记录
Dim pickedRows As String
For i = 2 To lastRow
If InStr(pickedRows, "\" & i & "\") = 0 Then
colorIndex = 1
For m = LBound(arrKey) To UBound(arrKey)
key1 = key1 & arr(i, arrKey(m)) & "|"
Next
For j = i + 1 To lastRow
For m = LBound(arrKey) To UBound(arrKey)
key2 = key2 & arr(j, arrKey(m)) & "|"
Next
If key2 = key1 Then
ws.Range(Cells(i, 1), Cells(i, lastColumn)).Interior.Color = PickColor(0)
ws.Range(Cells(j, 1), Cells(j, lastColumn)).Interior.Color = PickColor(colorIndex)
pickedRows = pickedRows & "\" & j & "\"
ws.Cells(j, markCol) = "第" & i & "行[" & colorIndex & "次重复]"
colorIndex = colorIndex + 1
End If
key2 = ""
Next
End If
key1 = ""
Next
MsgBox "查重结束！所有重复的已标色，无重复的为白色！"
End Sub
3、重复值删除代码：
Sub DeleteDuplicateRecords() '删除重复
Dim ws As Worksheet, destSheet As Worksheet
Dim lastRow As Long, lastColumn As Long
Dim colorIndex As Integer
Dim arr(), tbTitle()
Dim destRow As Integer, firstRow As Integer
Dim arrKey() As String
If Not wContinue("即将删除重复记录，此操作不可恢复，请确认！") Then Exit Sub
For i = LBound(arrFields) To UBound(arrFields)
If Me.Controls("CheckBox" & i) = True Then
ReDim Preserve arrKey(k)
arrKey(k) = i + 1
k = k + 1
End If
Next
If k = 0 Then
MsgBox "请至少选择一个科目！"
Exit Sub
End If
ThisWorkbook.Activate
Set ws = ThisWorkbook.Sheets("明细表")
ws.Activate
lastRow = ws.UsedRange.Rows.Count
lastColumn = ws.UsedRange.Columns.Count
arr = ws.Range(Cells(1, 1), Cells(lastRow, lastColumn)).Value
ws.Range(Cells(2, 1), Cells(lastRow, lastColumn)).Interior.Color = vbWhite
'标记重复记录
Dim pickedRows As String
For i = 2 To lastRow
If InStr(pickedRows, "\" & i & "\") = 0 Then
For m = LBound(arrKey) To UBound(arrKey)
key1 = key1 & arr(i, arrKey(m)) & "|"
Next
For j = i + 1 To lastRow
For m = LBound(arrKey) To UBound(arrKey)
key2 = key2 & arr(j, arrKey(m)) & "|"
Next
If key2 = key1 Then
pickedRows = pickedRows & "\" & j & "\"
End If
key2 = ""
Next
End If
key1 = ""
Next
'创建 "重复" 工作表
On Error Resume Next
Set destSheet = ThisWorkbook.Worksheets("重复")
On Error GoTo 0
If destSheet Is Nothing Then
'创建新的工作表
Set sht = ThisWorkbook.Worksheets.Add
sht.Name = "重复"
Set destSheet = sht
Else
destSheet.UsedRange.Delete Shift:=xlShiftUp
End If
ws.Rows(1).Copy destSheet.Rows(1)
'destRow = destSheet.UsedRange.Rows.Count + 1
With destSheet
destRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
firstRow = destRow
End With
For i = lastRow To 2 Step -1
k = InStr(pickedRows, "\" & i & "\")
If InStr(pickedRows, "\" & i & "\") > 0 Then
ws.Rows(i).Copy Destination:=destSheet.Cells(destRow, 1)
destRow = destRow + 1 '
ws.Rows(i).Delete
End If
Next
ws.Activate
MsgBox "成功删除【" & destRow - firstRow & "】条重复记录！"
End Sub
4、自定定义颜色序列代码（根据不同数字选择不同颜色），根据重复的次数不同选择不同的颜色：
Function PickColor(index As Integer) As Long
Select Case index
Case 0
PickColor = RGB(255, 255, 0) ' 黄色
Case 1
PickColor = RGB(0, 255, 0) ' 绿色
Case 2
PickColor = RGB(0, 255, 255) ' 青色
Case 3
PickColor = RGB(128, 128, 128) ' 灰色
Case 4
PickColor = RGB(255, 0, 255) ' 紫色
Case 5
PickColor = RGB(0, 0, 255) ' 蓝色
Case 6
PickColor = RGB(255, 128, 0) ' 橙色
Case 7
PickColor = RGB(128, 0, 255) ' 粉色
Case 8
PickColor = RGB(255, 0, 0) ' 红色
Case Else
'如果超出范围，则返回黑色
PickColor = RGB(0, 0, 0) ' 黑色
End Select
End Function
5、其他代码
（1）自定义函数：确认继续
Function wContinue(Msg) As Boolean
'确认继续函数
Dim Config As Long
Dim a As Long
Config = vbYesNo + vbQuestion + vbDefaultButton2
Ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config)
wContinue = Ans = vbYes
End Function
（2）“删重”按钮：
Private Sub CmdDelete_Click()
Call DeleteDuplicateRecords
Unload Me
End Sub
（3）“退出”按钮：
Private Sub CmdExit_Click()
Unload Me
End Sub
（4）“标重”按钮：
Private Sub CmdHighlight_Click()
Call HighlightDuplicateRecords
Unload Me
End Sub
（5）“全选”按钮：
Private Sub CmdSelect_Click()
If Me.CmdSelect.Caption = "全选" Then
For i = LBound(arrFields) To UBound(arrFields)
Me.Controls("CheckBox" & i) = True
Next
Me.CmdSelect.Caption = "全消"
Else
For i = LBound(arrFields) To UBound(arrFields)
Me.Controls("CheckBox" & i) = False
Next
Me.CmdSelect.Caption = "全选"
End If
End Sub
☆往期合集☆【2023年3月】【2023年4月】