加载中…
个人资料
微博
  • 博客等级：
  • 博客积分：
  • 博客访问：
  • 关注人气：
  • 获赠金笔：0支
  • 赠出金笔：0支
  • 荣誉徽章：
正文 字体大小：大 中 小

vba通过字典检测某列的重复内容

(2018-08-28 20:50:19)
标签：

dictionary

scripting

检测重复内容

检测一列的重复内容

给重复内容标色

 分类： Excel_VBA
vba通过字典检测某列的重复内容

----------------------------------------------------------------

Sub test_2()
    '--用来给重复项(包含第1次出现的内容)标色,通过测试
    Dim d, arr, i
    Set d = CreateObject("scripting.dictionary")
    Dim Hang  As Long
    Dim Lie As Long
    Dim Hang_QiShi As Long
    Dim ZhHang As Long
    Dim CiShu As Long
    With Worksheets("检测第M列的重复项")
         Lie = 13
         Hang_QiShi = 11
         ZhHang = .Cells(.Rows.Count, Lie).End(xlUp).Row
         arr = .Range(.Cells(Hang_QiShi, Lie), .Cells(ZhHang, Lie))                       '--可行
         For i = 1 To UBound(arr)
             d(arr(i, 1)) = d(arr(i, 1)) + 1
         Next
         
         For Hang = Hang_QiShi To ZhHang
              If d(.Cells(Hang, Lie).Value) > 1 Then
                    With .Cells(Hang, Lie)
                         .Interior.ColorIndex = 15                                          '--背景色
                         .Font.ColorIndex = 3                                               '--字体色
                    End With
              End If
         Next
    End With
End Sub
----------------------------------------------------------------
Sub test_3()
    '--用来给重复项(不包含第1次出现的内容)标色,通过测试
    Dim d, arr, i
    Set d = CreateObject("scripting.dictionary")
    Dim Hang  As Long
    Dim Lie As Long
    Dim Hang_QiShi As Long
    Dim ZhHang As Long
    Dim CiShu As Long
    With Worksheets("检测第M列的重复项")
         Lie = 13
         Hang_QiShi = 11
         ZhHang = .Cells(.Rows.Count, Lie).End(xlUp).Row
         arr = .Range(.Cells(Hang_QiShi, Lie), .Cells(ZhHang, Lie))                       '--可行
         For i = 1 To UBound(arr)
             d(arr(i, 1)) = d(arr(i, 1)) + 1
             Hang = i + 10
             If d(.Cells(Hang, Lie).Value) > 1 Then
                   With .Cells(Hang, Lie)
                        .Interior.ColorIndex = 15                                          '--背景色
                        .Font.ColorIndex = 3                                               '--字体色
                   End With
             End If
         Next
    End With
End Sub

----------------------------------------------------------------
Sub Macro1_2()
    '--判断某列的内容,出现的次数(包含第1次出现的内容)
    Dim arr
    Dim i As Long
    Dim d As Object
    Dim Hang  As Long
    Dim Lie As Long
    Dim Hang_QiShi As Long
    Dim ZhHang As Long
    Dim CiShu As Long
    
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("检测第M列的重复项")
         Lie = 13                                                                         '--需要检测的列号
         Hang_QiShi = 11                                                                  '--从第几行开始检测(需要取出标题行)
         ZhHang = .Cells(.Rows.Count, Lie).End(xlUp).Row                                  '--检测列的最后行
         arr = .Range(.Cells(Hang_QiShi, Lie), .Cells(ZhHang, Lie))                       '--将列+开始行+结束行的范围的内容,赋值给数组
         For i = 1 To UBound(arr)                                                         '--对数组内容进行循环
             If Len(arr(i, 1)) = 0 Then
                  Exit For
             End If
             d(arr(i, 1)) = d(arr(i, 1)) + 1
             Hang = i + 10
             Cells(Hang, Lie + 1).Value = d(arr(i, 1))                                    '--因为hang变量,比i多10(既要去掉标题行开始)
         Next
    End With

End Sub
----------------------------------------------------------------

Sub Macro1_3()
    '--判断某列的内容,出现的次数(不包含第1次出现的内容)
    Dim arr
    Dim i As Long
    Dim d As Object
    Dim Hang  As Long
    Dim Lie As Long
    Dim Hang_QiShi As Long
    Dim ZhHang As Long
    Dim CiShu As Long
    
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("检测第M列的重复项")
         Lie = 13                                                                         '--需要检测的列号
         Hang_QiShi = 11                                                                  '--从第几行开始检测(需要取出标题行)
         ZhHang = .Cells(.Rows.Count, Lie).End(xlUp).Row                                  '--检测列的最后行
         arr = .Range(.Cells(Hang_QiShi, Lie), .Cells(ZhHang, Lie))                       '--将列+开始行+结束行的范围的内容,赋值给数组
         For i = 1 To UBound(arr)                                                         '--对数组内容进行循环
            'If Len(arr(i, 1)) = 0 Then
            '     Exit For
            'End If
             d(arr(i, 1)) = d(arr(i, 1)) + 1
             Hang = i + 10
             If d(.Cells(Hang, Lie).Value) > 1 Then
                   Cells(Hang, Lie + 1).Value = d(arr(i, 1))                                    '--因为hang变量,比i多10(既要去掉标题行开始)
             End If
         Next
    End With

End Sub

----------------------------------------------------------------

整理后内容:

Public Sub jch01_05_明细表_页签_根据参数设置格式_重复项检测并标色()
    '---不包含第1次出现的内容
    '----<5.2重复项检测并标色>
    Set EL_App = GetObject(, "Excel.Application")
    '--用来给重复项(不包含第1次出现的内容)标色,通过测试
    YanSe_BeiJing_1 = RGB(176, 224, 230)                                                      '--默认背景色(浅色)
    YanSe_BeiJing_2 = RGB(141, 182, 205)                                                      '--默认中间边框色(浅色)
    Dim d, arr, i
    Set d = CreateObject("scripting.dictionary")
    Dim Hang  As Long
    Dim Hang_QiShi As Long
    Dim ZhHang As Long
    Dim Lie As Long
    Dim ZhLie As Long
    If EL_App.Worksheets("单据-设置").Cells(112, 118).Value = "是" Then
         With EL_App.Worksheets("jch01-05")
               ZhLie = .Cells(10, .Columns.Count).End(xlToLeft).Column
               For Lie = 1 To ZhLie
                    If .Cells(9, Lie).Value = "2.1重复项检测并标色" Then
                         .Cells(8, Lie).Value = Lie                                                        '--填写检测列的列号
                          Hang_QiShi = 11
                          ZhHang = .Cells(.Rows.Count, Lie).End(xlUp).Row
                          arr = .Range(.Cells(Hang_QiShi, Lie), .Cells(ZhHang, Lie))                       '--可行
                          For i = 1 To UBound(arr)
                               If Len(arr(i, 1)) = 0 Then                                                  '---不判断为空的内容(单元格为空不判断)
                                     GoTo AAA
                               End If
                               '--给字典赋值
                               d(arr(i, 1)) = d(arr(i, 1)) + 1
                               Hang = i + 10
                               If d(.Cells(Hang, Lie).Value) > 1 Then
                                    .Cells(Hang, Lie).Interior.Color = YanSe_BeiJing_1
                               End If
AAA:
                          Next
                          '--清空或重置字典,下次循环,重新赋值(如果用Set d = Nothing,则必须重新定义字典)
                          d.RemoveAll
                         '--清除动态数组,释放数组所用内存,只适用动态数组
                          Erase arr
                    
                    End If
               Next
         End With
    End If
    
    
End Sub

Public Sub jch01_05_明细表_页签_根据参数设置格式_重复项进行计数()
    '----<5.3重复项,后列标注重复次数>
    Set EL_App = GetObject(, "Excel.Application")
    '--'--判断某列的内容,出现的次数(不包含第1次出现的内容)
    YanSe_BeiJing_1 = RGB(176, 224, 230)                                                      '--默认背景色(浅色)
    YanSe_BeiJing_2 = RGB(141, 182, 205)                                                      '--默认中间边框色(浅色)
    Dim d, arr, i
    Set d = CreateObject("scripting.dictionary")
    Dim Hang  As Long
    Dim Hang_QiShi As Long
    Dim ZhHang As Long
    Dim Lie_1 As Long
    Dim Lie As Long
    Dim ZhLie As Long
    If EL_App.Worksheets("单据-设置").Cells(113, 118).Value = "是" Then
         With EL_App.Worksheets("jch01-05")
               ZhLie = .Cells(10, .Columns.Count).End(xlToLeft).Column
               For Lie_1 = 1 To ZhLie
                    If .Cells(9, Lie_1).Value = "2.2填写重复次数" Then
                          Lie = Val(.Cells(8, Lie_1).Value)                                     '--获取计算重复项所在的列
                          If Lie > 0 Then
                               Hang_QiShi = 11
                               ZhHang = .Cells(.Rows.Count, Lie).End(xlUp).Row
                               arr = .Range(.Cells(Hang_QiShi, Lie), .Cells(ZhHang, Lie))       '--可行
                               For i = 1 To UBound(arr)
                                    If Len(arr(i, 1)) = 0 Then                                                  '---不判断为空的内容(单元格为空不判断)
                                          GoTo AAA
                                    End If
                                   '--给字典赋值
                                    d(arr(i, 1)) = d(arr(i, 1)) + 1
                                    Hang = i + 10
                                    If d(.Cells(Hang, Lie).Value) > 1 Then
                                          .Cells(Hang, Lie_1).Value = d(arr(i, 1))              '--因为hang变量,比i多10(既要去掉标题行开始)
                                    End If
AAA:
                               Next
                              '--清空或重置字典,下次循环,重新赋值(如果用Set d = Nothing,则必须重新定义字典)
                               d.RemoveAll
                              '--清除动态数组,释放数组所用内存,只适用动态数组
                               Erase arr
                          Else                                                                  '--如果忘记填写对应列号,则
                               .Cells(8, Lie_1).Interior.Color = YanSe_BeiJing_2
                          End If
                    End If
               Next
         End With
    End If
End Sub


-----------------------------------------------------------------------------------
-----------------------------------------------------------------------------------


'--将重复数值中,第一次出现的重复值标色和不标色放到一起,根据需要调整
Public Sub jch01_05_明细表_页签_根据参数设置格式_重复项检测并标色_()
   '----<5.2重复项检测并标色>
    Dim EL_App As Object
    Dim YanSe_BeiJing_1
    Dim YanSe_BeiJing_2
    
    Set EL_App = GetObject(, "Excel.Application")
   '--用来给重复项(不包含第1次出现的内容)标色,通过测试
    YanSe_BeiJing_1 = RGB(176, 224, 230)                                             '--默认背景色(浅色)
    YanSe_BeiJing_2 = RGB(141, 182, 205)                                             '--默认中间边框色(浅色)
    Dim d, arr, i
    Set d = CreateObject("scripting.dictionary")
    Dim Hang  As Long
    Dim Hang_QiShi As Long
    Dim ZhHang As Long
    Dim Lie As Long
    Dim ZhLie As Long
    If EL_App.Worksheets("单据-设置").Cells(112, 118).Value = "是" Then
        With EL_App.Worksheets("jch01-05")
             ZhLie = .Cells(10, .Columns.Count).End(xlToLeft).Column
             For Lie = 1 To ZhLie
                 If .Cells(9, Lie).Value = "2.1重复项检测并标色" Then
                     .Cells(8, Lie).Value = Lie                                              '--填写检测列的列号
                      Hang_QiShi = 11
                      ZhHang = .Cells(.Rows.Count, Lie).End(xlUp).Row
                      arr = .Range(.Cells(Hang_QiShi, Lie), .Cells(ZhHang, Lie))             '--可行
                     '--不包含第一次重复的数值------开始
'                      For i = 1 To UBound(arr)
'                          If Len(arr(i, 1)) = 0 Then                                        '--不判断为空的内容(单元格为空不判断)
'                               GoTo AAA
'                          End If
'                          d(arr(i, 1)) = d(arr(i, 1)) + 1                                   '--给字典赋值
'                          Hang = i + 10
'                          If d(.Cells(Hang, Lie).Value) > 1 Then
'                              .Cells(Hang, Lie).Interior.Color = YanSe_BeiJing_1
'                          End If
'AAA:
'                      Next
                     '--不包含第一次重复的数值------结束
                     '----包含第一次重复的数值------开始
                      For i = 1 To UBound(arr)
                          If Len(arr(i, 1)) = 0 Then                                         '--不判断为空的内容(单元格为空不判断)
                               GoTo BBB
                          End If
                          d(arr(i, 1)) = d(arr(i, 1)) + 1                                    '--给字典赋值
BBB:
                      Next
                      For Hang = Hang_QiShi To ZhHang
                          If d(.Cells(Hang, Lie).Value) > 1 Then
                             .Cells(Hang, Lie).Interior.Color = YanSe_BeiJing_1
                          End If
                      Next
                      '----包含第一次重复的数值------结束
                      '--清空或重置字典,下次循环,重新赋值(如果用Set d = Nothing,则必须重新定义字典)
                      d.RemoveAll
                     '--清除动态数组,释放数组所用内存,只适用动态数组
                      Erase arr
                 End If
             Next
        End With
    End If
End Sub






















喜欢

0

阅读┊ 收藏 ┊ 喜欢▼ ┊打印┊举报/Report
  

新浪BLOG意见反馈留言板　欢迎批评指正

新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 产品答疑

Copyright © 1996 - 2022 SINA Corporation, All Rights Reserved

新浪公司 版权所有