[發問] 關於移除重複額外加上一段判斷

av8d

我忘記在某板大大所提供的程式如下

1.     Dim Rng As Range, Ar, i%
   
2.     Set Rng = [C1:C10]
   
3.     Ar = Application.Transpose(Rng)
   
4.     For i = UBound(Ar) To 1 Step -1
   
5.         If Application.CountIf(Rng, "=" & Ar(i)) > 1 Then Rng(i) = ""
   
6.     Next    ''
   
7.     ''''''''''上面程式碼  將重複資料的位置為空白 ''''''''''''''''''''''''
   
8.     Rng.SpecialCells(xlCellTypeBlanks).Delete xlUp    '空白位置刪除的動作

複製代碼

當沒有重複的時候，程式會跑錯誤
Rng.SpecialCells(xlCellTypeBlanks).Delete xlUp    '空白位置刪除的動作
我該如何改寫判斷呢?謝謝!

我剛改寫了一下，好像是這樣就可以了，不知道對不不對，如下

1.     Dim Rng As Range, Ar, i%
   
2.     Set Rng = [C1:C10]
   
3.     Ar = Application.Transpose(Rng)
   
4.     For i = UBound(Ar) To 1 Step -1
   
5.         If Application.CountIf(Rng, "=" & Ar(i)) > 1 Then
   
6.         Rng(i) = ""
   
7.         Rng.SpecialCells(xlCellTypeBlanks).Delete xlUp    '空白位置刪除的動作
   
8.         End If
   
9.     Next    ''

複製代碼

GBKEE

回復 1# av8d
     Dim Rng As Range, Ar, i%, Msg As Boolean
    Set Rng = [C1:C10]
    Ar = Application.Transpose(Rng)
    For i = UBound(Ar) To 1 Step -1
        If Application.CountIf(Rng, "=" & Ar(i)) > 1 Then
            Rng(i) = ""
            Msg = True                '輔助判斷: 有一個空白以上
        End If        
    Next    '
    ''''''''''上面程式碼  將重複資料的位置為空白 ''''''''''''''''''''''''
    If Msg Then Rng.SpecialCells(xlCellTypeBlanks).Delete xlUp    '空白位置刪除的動作

av8d

回復 2# GBKEE


    大大您好~如果是要把
If Msg Then Rng.SpecialCells(xlCellTypeBlanks).Delete xlUp    '空白位置刪除的動作

更改成空白列~


如果是C2就是第2列~B3就是第三列~該如何修改?

GBKEE

回復 3# av8d
不太了解你的意思
Set Rng = [C1:C10]    改這裡的範圍 看看

Hsieh

回復 3# av8d

If Msg Then Rng.SpecialCells(xlCellTypeBlanks).Entirerow.Delete