玖叶教程网

前端编程开发入门

2024年04月08日

Excel VBA 通用版工作表重复值处理模板代码

本文于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月】

☆猜你喜欢☆

Excel VBA 电子发票管理助手

Excel VBA 文件批量改名

Excel VBA 中医诊所收费系统

Excel VBA 动态添加控件

Excel VBA 酷炫的日期控件

Excel 固定资产折旧计提表

Excel VBA 最简单的收发存登记系统

Excel 公式函数/查找函数之LOOKUP

Excel VBA 输入逐步提示

Excel 基础功能【数据验证】

本文于2023年6月21日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！

标签：vbainstr 

作者:gojiuye , 分类:技术精选 , 浏览:20 , 评论:0

发表评论:

控制面板
您好，欢迎到访网站！
  查看权限
网站分类
最新留言