[已解决]删除不尽问题

fangniuji

这代码哪里出错，帮我改改，本来全部要删除，现在只删掉一部分，本来结果要全部删掉，谢谢。
ub 取数()
    Dim d As Object, arr(), ar
    Dim i&, j&, k&
        Set d = CreateObject("scripting.dictionary")
        For i = 3 To Cells(Rows.Count, "i").End(3).Row
            If Cells(i, "l") = "×" Then d(Cells(i, "i").Text) = ""
        Next i
        ar = Range("b1").Resize(Cells(Rows.Count, 1).End(3).Row, 3)
        For j = 1 To UBound(ar)
            If d.Exists(ar(j, 1)) = False Then
                k = k + 1
                ReDim Preserve arr(1 To 3, 1 To k)
                arr(1, k) = ar(j, 1)
                arr(2, k) = ar(j, 2)
                arr(3, k) = ar(j, 3)
            End If
        Next j
        Range("b1:d" & Cells(Rows.Count, "j").End(3).Row).ClearContents
        Range("b1").Resize(k, 3) = Application.Transpose(arr)
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-11-30 16:06

1. Sub 取数()
   
2.     Dim d As Object, arr(), ar
   
3.     Dim i&, j&, k&
   
4.         Set d = CreateObject("scripting.dictionary")
   
5.         For i = 3 To Cells(Rows.Count, "i").End(3).Row
   
6.             If Cells(i, "l") = "×" Then d(Cells(i, "i").Text) = ""
   
7.         Next i
   
8.         ar = Range("b1").Resize(Cells(Rows.Count, 2).End(3).Row, 3)
   
9.         For j = 1 To UBound(ar)
   
10.             If d.Exists(ar(j, 1)) = False Then
    
11.                 k = k + 1
    
12.                 ReDim Preserve arr(1 To 3, 1 To k)
    
13.                 arr(1, k) = ar(j, 1)
    
14.                 arr(2, k) = ar(j, 2)
    
15.                 arr(3, k) = ar(j, 3)
    
16.             End If
    
17.         Next j
    
18.         Range("b1:d" & Cells(Rows.Count, "b").End(3).Row).ClearContents
    
19.         Range("b1").Resize(k, 3) = Application.Transpose(arr)
    
20. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

程序要实现什么功能，直接说功能吧。

hwc2ycy

你I列做为字典的关键字就不行啦，I列基本上全是空的，如何写进字典。

hwc2ycy

1. ar = Range("b1").Resize(Cells(Rows.Count, 1).End(3).Row, 3)

复制代码

你的A列全为空，行数不就变成1了。

fangniuji

hwc2ycy 发表于 2012-11-30 14:35
你的A列全为空，行数不就变成1了。

还是没有办法全部删除，再看看，谢谢！！！

hwc2ycy

你告诉我删除的依据是什么

fangniuji

hwc2ycy 发表于 2012-11-30 14:57
你告诉我删除的依据是什么

I3后面L3打叉，就把前面B2到D列 跟I3一样的T全部删除。

hwc2ycy

1. Sub 取数()
   
2.     Dim d As Object, arr(), ar
   
3.     Dim i&, j&, k&
   
4.         Set d = CreateObject("scripting.dictionary")
   
5.         For i = 3 To Cells(Rows.Count, "i").End(3).Row
   
6.             If Cells(i, "l") = "×" Then d(Cells(i, "i").Text) = ""
   
7.         Next i
   
8.         ar = Range("b1").Resize(Cells(Rows.Count, 2).End(3).Row, 3)
   
9.         For j = 1 To UBound(ar)
   
10.             If d.Exists(ar(j, 1)) = False Then
    
11.                 k = k + 1
    
12.                 ReDim Preserve arr(1 To 3, 1 To k)
    
13.                 arr(1, k) = ar(j, 1)
    
14.                 arr(2, k) = ar(j, 2)
    
15.                 arr(3, k) = ar(j, 3)
    
16.             End If
    
17.         Next j
    
18.         Range("b1:d" & Cells(Rows.Count, "b").End(3).Row).ClearContents
    
19.         Range("b1").Resize(k, 3) = Application.Transpose(arr)
    
20. End Sub

复制代码