用字典分组排序填充

sero61

如题，不使用排序功能的情况下，能否使用字典进行排序填充

C列为期值达到的效果 ，B列为使用字典。但在不排序的情况下，重复出现的就没办法再次从1重排。请路过大神给点思路，或指点一下是否在钻牛角尖

醉眼看尘世

一个公式的问题，你要来整VBA，还指定技术路线要字典。。。
B2公式
=IF(A2<>A1,1,B1+1)

醉眼看尘世

然后把公式改造成VBA就是

1. Sub test()
   
2. Arr = Sheet1.[a1].CurrentRegion
   
3. For i = 2 To UBound(Arr, 1)
   
4.     If Arr(i, 1) <> Arr(i - 1, 1) Then
   
5.         Arr(i, 2) = 1
   
6.     Else
   
7.         Arr(i, 2) = Arr(i - 1, 2) + 1
   
8.     End If
   
9. Next i
   
10. Sheet1.[a1].CurrentRegion = Arr
    
11. End Sub
    

复制代码

无关岁月

分组排序.7z (18.09 KB, 下载次数: 3)

2024-9-8 21:00 上传

点击文件名下载附件

sero61

醉眼看尘世 发表于 2024-9-8 20:53
一个公式的问题，你要来整VBA，还指定技术路线要字典。。。
B2公式
=IF(A2A1,1,B1+1)

感谢指点 主要是学习思路

sero61

无关岁月 发表于 2024-9-8 21:01

感谢回复  指教  大神无处不在

jaxxcyh

1. Sub s()
   
2. Dim rg As Range, x, brr()
   
3. Dim d As New Dictionary
   
4. Dim change As Boolean
   
5. arr = Sheets(1).Range("a2:a" & Cells(Rows.Count, 1).End(3).Row)
   
6. ReDim Preserve brr(1 To UBound(arr))
   
7. 
   
8. For i = 1 To UBound(arr)
   
9.     change = False
   
10.     If Not d.Exists(arr(i, 1)) Then change = True
    
11.     If i > 1 Then
    
12.         If arr(i, 1) <> arr(i - 1, 1) Then change = True
    
13.     End If
    
14.    
    
15.     If change Then
    
16.         d(arr(i, 1)) = ""
    
17.         brr(i) = 1
    
18.         n = 1
    
19.     Else
    
20.         n = n + 1
    
21.         brr(i) = n
    
22.     End If
    
23. Next i
    
24. Sheets(1).Range("b2").Resize(UBound(brr)) = Application.Transpose(brr)
    
25. End Sub
    

复制代码

sero61

醉眼看尘世 发表于 2024-9-8 20:55
然后把公式改造成VBA就是

看来是钻牛角尖了， 用单元格循环能否成功

chxw68

单元格循环的，速度比较慢。

1. Sub test()
   
2.     Dim r%, i%
   
3.     With Worksheets("sheet1")
   
4.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
5.         For i = 2 To r
   
6.             If .Cells(i, 1) <> .Cells(i - 1, 1) Then
   
7.                 .Cells(i, 3) = 1
   
8.             Else
   
9.                 .Cells(i, 3) = .Cells(i - 1, 3) + 1
   
10.             End If
    
11.         Next
    
12.     End With
    
13. End Sub
    

复制代码

chxw68

楼主要求的单元格循环的，速度比较慢。