关于剔除重复

tanhong

小妖有一好多法宝要慢慢亮出来,快闪.............[:33]

tanhong

Sub 删除重复()
Dim Lrow As Long
Dim I As Integer
Dim J As Integer
Dim myCount
   
   '关闭刷屏
  Application.ScreenUpdating = False
   
   '得到数据总行数
  Lrow = Sheets("sheet1").[A65536].End(xlUp).Row
   
  '避开标题行,即从第二行到最后一行进行循环
  For I = 2 To Lrow
      '因为考虑到进行删除操作后,需重更新得到数据总行数
      Lrow = Sheets("sheet1").[A65536].End(xlUp).Row
      '重第二行向新得到的总行数进行循环
      For J = 2 To Lrow
                 
          '按遍历单元格条件进行计数
          myCount = Application.CountIf(Sheet1.Range("A2:A" & Lrow), Sheets("sheet1").Cells(I, 1))
                  
          '计数大于1,对所在行进行删除操作
          If myCount > 1 Then
              Sheets("sheet1").Cells(I, 1).Delete
          End If
      Next J
   
   Next I
  
   '打开刷屏
  Application.ScreenUpdating = True
End Sub

以上我完善后的代码,不需要再重复点击了,哈哈....少了点击的快乐了!

[ 本帖最后由 tanhong 于 2008-3-26 19:34 编辑 ]

pureshadow

函数是有无数种解决方法的，先来一种较易理解的：

例如原数据在A2：A11，要剔除重复。

核心在于把不重复的按序排好，重复的T到一边去：
SMALL(IF(MATCH($A$2: $A$11,$A$2: $A$11,)=ROW($A$1: $A$10),ROW($A$1: $A$10),65536),ROW(A1))（计算过程如下图）

为简化公式，可以把以上自定义为focus

接下来，随你选INDEX/OFFSET/INDIRECT

=INDEX($A$2: $A$11,focus,1)
=OFFSET($A$1,focus,)
=INDIRECT("a"&focus+1)

[ 本帖最后由 pureshadow 于 2008-3-26 21:36 编辑 ]

tanhong

小妖版主有一大堆的方法，期待哦。。。。。。

pureshadow

我们约好的哦，我出多少函数，你就得出多少VBA[:34]

tanhong

[:30] 成心为难我哦，你储备充足..........[:27]

tanhong

受小妖版主技巧操作的启发，做出第三段代码，在此对小妖版主表示感谢！

主要思路：
1、首先进行排序
2、用A1=A2判断进区别是否重复，为真则表示重复
3、对为真的行进行循环删除

代码如下：

Sub 删除重复二()
Dim LRow As Long
Dim I As Integer
Dim J As Integer
Dim myBoolean As Boolean
   
   Application.ScreenUpdating = False
   
   LRow = Sheets("sheet1").[A65536].End(xlUp).Row
   '进行排序
   Range("A2:A" & LRow).Sort Key1:=Range("A2")
   
   For I = 2 To LRow

      LRow = Sheets("sheet1").[A65536].End(xlUp).Row
  
      For J = 2 To LRow
         '得到布尔值
          myBoolean = Sheet1.Range("A" & I - 1) = Sheet1.Range("A" & I)
          '值为真则进行删除
          If myBoolean = True Then
             Sheets("sheet1").Cells(I, 1).Delete
          End If
      Next J
   
   Next I
  
   Application.ScreenUpdating = True
End Sub

pureshadow

我也来段代码，我自己弄的，江版看了不要吐血哦[:34]

Sub M()

Dim myrow As Long
Dim myrng As Range

myrow = Range("a65536").End(xlUp).Row
Set myrng = Range("a1:a" & myrow)

myrng.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1"), Unique:=True

End Sub

[ 本帖最后由 pureshadow 于 2008-3-26 21:59 编辑 ]

tanhong

哈哈,收网了哦,打到鱼了[:32]

Jonathan.K

1. Sub test()
   
2.     Dim rngData As Variant
   
3.     Dim i As Long
   
4.     Dim oDic As Object
   
5.    
   
6.     Application.ScreenUpdating = False
   
7.     Set oDic = CreateObject("Scripting.Dictionary")
   
8.     With Sheet1
   
9.         rngData = .[a1].Resize(.[a65536].End(xlUp).Row)
   
10.         For i = 1 To UBound(rngData)
    
11.             oDic(rngData(i, 1)) = ""
    
12.         Next
    
13.         .[c1].Resize(oDic.Count) = Application.Transpose(oDic.keys)
    
14.     End With
    
15.     Application.ScreenUpdating = True
    
16.     Set oDic = Nothing
    
17. End Sub

复制代码