[已解决]求助大神把03的vba修改成07的

瀚海人

Sub aaa()
Dim arr, i&, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("b2:b" & [b65536].End(3).Row)
ReDim Preserve arr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
  If d.exists(arr(i, 1)) Then arr(i, 2) = i - d(arr(i, 1)) - 1 Else arr(i, 2) = i - 1
  d(arr(i, 1)) = i
Next i
[c2].Resize(UBound(arr)) = Application.Index(arr, , 2)
End Sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-12-2 19:01

1. Sub aaa()
   
2.     Dim arr, i&, d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("b2:b" & Cells(Rows.Count, 2).End(xlUp).Row)
   
5.     ReDim Preserve arr(1 To UBound(arr), 1 To 2)
   
6.     For i = 1 To UBound(arr)
   
7.         If d.exists(arr(i, 1)) Then arr(i, 2) = i - d(arr(i, 1)) - 1 Else arr(i, 2) = i - 1
   
8.         d(arr(i, 1)) = i
   
9.     Next i
   
10.     [c2].Resize(UBound(arr)) = Application.Index(arr, , 2)
    
11. End Sub

复制代码

2010下运行正常。

跳转到最佳答案楼层

E路人

arr = Range("b2:b" & [b65536].End(3).Row)  改成B1048576 看看

瀚海人

改成B1048576 测试过了
[c2].Resize(UBound(arr)) = Application.Index(arr, , 2)
报错

xdragon

arr = Range("b2:b" & cells(rows.count,2).End(3).Row)
改成通用的吧，03 07都可以的哈

我心飞翔410

Sub aaa()
Dim arr, i&, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Range("b2:b" & Cells(Rows.Count, "b").End(3).Row)   '改为这句试试
ReDim Preserve arr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
  If d.exists(arr(i, 1)) Then arr(i, 2) = i - d(arr(i, 1)) - 1 Else arr(i, 2) = i - 1
  d(arr(i, 1)) = i
Next i
[c2].Resize(UBound(arr)) = Application.Index(arr, , 2)
End Sub
本身是通用的 只是你那个 只适合03的 65536 行   我改的这句适合 07 10 的10万多行

E路人

瀚海人 发表于 2013-12-2 14:36
改成B1048576 测试过了
[c2].Resize(UBound(arr)) = Application.Index(arr, , 2)
报错

你的数据有没有合并单元格,数据也不会有100多万行,差不多就行了,要不上附件

瀚海人

我心飞翔410 发表于 2013-12-2 14:38
Sub aaa()
Dim arr, i&, d As Object
Set d = CreateObject("scripting.dictionary")

我测试了也不行

E路人

瀚海人 发表于 2013-12-2 14:36
改成B1048576 测试过了
[c2].Resize(UBound(arr)) = Application.Index(arr, , 2)
报错

要保存为.xlsm格式,不能在兼容模式下使用

瀚海人

我上传附件了
各位大神看看

瀚海人

E路人 发表于 2013-12-2 14:34
arr = Range("b2:b" & [b65536].End(3).Row)  改成B1048576 看看

上传附件了
各位大神看看