如果删除相同项目，谢谢啊，急救哦，期待

shgmp

自动删除功能.rar (6.04 KB, 下载次数: 6)

2013-9-16 23:29 上传

点击文件名下载附件

级别由高到低是：熟练，掌握，了解

对于同一个文件编号，如果程度中出现两种以上的级别，只保留最高级别，比如左边黄色文件，只希望最后保留熟练；对于绿色，只保留掌握；对灰色部分，只保留熟练；

非常感谢

shgmp

在线等待哦，谢谢啊

yaozong

Sub test()
  Dim d, arr, s$, i&, j&, m&
  Set d = CreateObject("scripting.dictionary")
  arr = Range("b1", Cells(Rows.Count, "C").End(3).Offset(, 1)).Value
  ReDim brr(1 To UBound(arr), 1 To 3)
  ar = Array("熟练", "掌握", "了解")
  For i = 1 To UBound(arr)
     For j = 0 To UBound(ar)
        If arr(i, 2) = ar(j) Then arr(i, 3) = j
     Next
     s = arr(i, 1)
     If Not d.exists(s) Then
        m = m + 1
        d(s) = m
        brr(m, 1) = arr(i, 1)
        brr(m, 3) = arr(i, 3)
        brr(m, 2) = ar(arr(i, 3))
     Else
        If brr(d(s), 3) > arr(i, 3) Then
           brr(d(s), 3) = arr(i, 3)
           brr(d(s), 2) = ar(arr(i, 3))
        End If
     End If
  Next
  Range("e:f").Clear
  Cells(1, "e").Resize(UBound(arr), 2) = brr
  Cells(1, "f") = "程度"
  Set d = Nothing
End Sub

yaozong

'.................

shgmp

yaozong 发表于 2013-9-17 07:51
'.................

老大，你好。可否能实现处理后的结果直接将原来的覆盖掉呢？而不是单独放在其它单元格

yaozong

shgmp 发表于 2013-9-17 08:02
老大，你好。可否能实现处理后的结果直接将原来的覆盖掉呢？而不是单独放在其它单元格

Sub test()
  Dim d, arr,ar, s$, i&, j&, m&
  Set d = CreateObject("scripting.dictionary")
  arr = Range("b2", Cells(Rows.Count, "C").End(3).Offset(, 1)).Value
  ReDim brr(1 To UBound(arr), 1 To 3)
  ar = Array("熟练", "掌握", "了解")
  For i = 1 To UBound(arr)
     For j = 0 To UBound(ar)
        If arr(i, 2) = ar(j) Then arr(i, 3) = j
     Next
     s = arr(i, 1)
     If Not d.exists(s) Then
        m = m + 1
        d(s) = m
        brr(m, 1) = arr(i, 1)
        brr(m, 3) = arr(i, 3)
        brr(m, 2) = ar(arr(i, 3))
     Else
        If brr(d(s), 3) > arr(i, 3) Then
           brr(d(s), 3) = arr(i, 3)
           brr(d(s), 2) = ar(arr(i, 3))
        End If
     End If
  Next
  Range("B2:C65536").Clear
  Cells(2, "B").Resize(UBound(arr), 2) = brr
  Set d = Nothing
End Sub

shgmp

yaozong 发表于 2013-9-17 09:11
Sub test()
  Dim d, arr,ar, s$, i&, j&, m&
  Set d = CreateObject("scripting.dictionary")

非常的感谢您

shgmp

yaozong 发表于 2013-9-17 09:11
Sub test()
  Dim d, arr,ar, s$, i&, j&, m&
  Set d = CreateObject("scripting.dictionary")

非常的感谢您

shgmp

yaozong 发表于 2013-9-17 09:11
Sub test()
  Dim d, arr,ar, s$, i&, j&, m&
  Set d = CreateObject("scripting.dictionary")

自动删除功能-替代源文件.rar (19.18 KB, 下载次数: 4)

2013-9-19 07:57 上传

点击文件名下载附件

老大，在使用的过程中，又出现新的问题了，烦请您看看，谢谢啊

yaozong

shgmp 发表于 2013-9-19 07:57
老大，在使用的过程中，又出现新的问题了，烦请您看看，谢谢啊

Sub test()
  Dim d, arr, ar, s$, i&, j&, m&
  Set d = CreateObject("scripting.dictionary")
  arr = Range("c10", Cells(Rows.Count, "F").End(3).Offset(, 1)).Value
  ReDim brr(1 To UBound(arr), 1 To 5)
  ar = Array("熟练", "掌握", "了解")
  For i = 1 To UBound(arr)
     For j = 0 To UBound(ar)
        If arr(i, 4) = ar(j) Then arr(i, 5) = j
     Next
     s = arr(i, 3)
     If Not d.exists(s) Then
        m = m + 1
        d(s) = m
        brr(m, 1) = arr(i, 1)
        brr(m, 2) = arr(i, 2)
        brr(m, 3) = arr(i, 3)
        brr(m, 5) = arr(i, 5)
        brr(m, 4) = ar(arr(i, 5))
     Else
        If brr(d(s), 5) > arr(i, 5) Then
           brr(d(s), 5) = arr(i, 5)
           brr(d(s), 4) = ar(arr(i, 5))
        End If
     End If
  Next
  Range("c10:f302").ClearContents
  Range("c10:f302").Interior.ColorIndex = False
  Cells(10, "c").Resize(m, 4) = brr
  Set d = Nothing
End Sub