關(guān)于剔除重復

tanhong

小妖有一好多法寶要慢慢亮出來,快閃.............[:33]

tanhong

Sub 刪除重復()
Dim Lrow As Long
Dim I As Integer
Dim J As Integer
Dim myCount
   
   '關(guān)閉刷屏
  Application.ScreenUpdating = False
   
   '得到數(shù)據(jù)總行數(shù)
  Lrow = Sheets("sheet1").[A65536].End(xlUp).Row
   
  '避開標題行,即從第二行到最后一行進行循環(huán)
  For I = 2 To Lrow
      '因為考慮到進行刪除操作后,需重更新得到數(shù)據(jù)總行數(shù)
      Lrow = Sheets("sheet1").[A65536].End(xlUp).Row
      '重第二行向新得到的總行數(shù)進行循環(huán)
      For J = 2 To Lrow
                 
          '按遍歷單元格條件進行計數(shù)
          myCount = Application.CountIf(Sheet1.Range("A2:A" & Lrow), Sheets("sheet1").Cells(I, 1))
                  
          '計數(shù)大于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

函數(shù)是有無數(shù)種解決方法的，先來一種較易理解的：

例如原數(shù)據(jù)在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

我們約好的哦，我出多少函數(shù)，你就得出多少VBA[:34]

tanhong

[:30] 成心為難我哦，你儲備充足..........[:27]

tanhong

受小妖版主技巧操作的啟發(fā)，做出第三段代碼，在此對小妖版主表示感謝！

主要思路：
1、首先進行排序
2、用A1=A2判斷進區(qū)別是否重復，為真則表示重復
3、對為真的行進行循環(huán)刪除

代碼如下：

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

哈哈,收網(wǎng)了哦,打到魚了[: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

復制代碼