18721107673
18721107673
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