|
您可以通过以下方式支持我：1、关注、点赞、留言、分享、打赏；2、点击感兴趣的广告、购买我的安利微店产品；3、添加我的合谷医疗企业微信，谢谢！ ☆本期内容概要☆ 所有代码均在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 'StopEnd 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 SelectEnd 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 = vbYesEnd Function
（2）“删重”按钮：
Private Sub CmdDelete_Click() Call DeleteDuplicateRecords Unload MeEnd Sub
（3）“退出”按钮： Private Sub CmdExit_Click() Unload MeEnd Sub
（4）“标重”按钮： Private Sub CmdHighlight_Click() Call HighlightDuplicateRecords Unload MeEnd 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 IfEnd Sub
|
