曾经的回帖整理-字典案例部分

liulang0808

1. Sub 按钮2_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = Sheets("原始数据").[a1].CurrentRegion
   
4.     Application.ScreenUpdating = False
   
5.     ActiveSheet.UsedRange.ClearContents
   
6.     [a1] = "客户姓名"
   
7.     For j = 2 To UBound(arr)
   
8.         If Not d.exists(arr(j, 1)) Then
   
9.             r = Cells(Rows.Count, 1).End(3).Row + 1
   
10.             d(arr(j, 1)) = r
    
11.             Cells(r, 1) = arr(j, 1)
    
12.         End If
    
13.         If Not d.exists(arr(j, 2)) Then
    
14.             c = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    
15.             d(arr(j, 2)) = c
    
16.             Cells(1, c) = arr(j, 2)
    
17.         End If
    
18.         Cells(d(arr(j, 1)), Cells(d(arr(j, 2)))) = arr(j, 3) + Cells(d(arr(j, 1)), Cells(d(arr(j, 2))))
    
19.     Next j
    
20.     Application.ScreenUpdating = True
    
21. End Sub
    
22. 数据转置，使用一个字典结合表格数据格式使用，注意A,B列数据不重名才可以的

复制代码

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set dsht = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("原始数据").[a1].CurrentRegion
   
5.     Application.ScreenUpdating = False
   
6.     For j = 1 To Sheets.Count
   
7.         dsht(Sheets(j).Name) = ""
   
8.     Next j
   
9.     With Sheets("原始数据")
   
10.         For j = 2 To UBound(arr)
    
11.             If d.exists(arr(j, 1)) Then
    
12.                 Set d(arr(j, 1)) = Union(d(arr(j, 1)), .Cells(j, 1).Resize(1, 3))
    
13.             Else
    
14.                 Set d(arr(j, 1)) = .Cells(j, 1).Resize(1, 3)
    
15.             End If
    
16.         Next j
    
17.    
    
18.         For j = 0 To d.Count - 1
    
19.             If dsht.exists(d.keys()(j)) Then
    
20.                 d.items()(j).Copy Sheets(d.keys()(j)).Cells(Rows.Count, 1).End(3).Offset(1)
    
21.             Else
    
22.                 Sheets.Add after:=Sheets(Sheets.Count)
    
23.                 Sheets(Sheets.Count).Name = d.keys()(j)
    
24.                 dsht(d.keys()(j)) = ""
    
25.                 .[a1:c1].Copy Sheets(d.keys()(j)).[a1]
    
26.                 d.items()(j).Copy Sheets(d.keys()(j)).Cells(Rows.Count, 1).End(3).Offset(1)
    
27.             End If
    
28.         Next j
    
29.     End With
    
30.     Application.ScreenUpdating = True
    
31. End Sub
    
32. 根据数据表内的姓名，将数据拆分到各张表内，如果对应表，不存在就创建新表

复制代码

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Randomize
   
5.     Do While d.Count < 10
   
6.         d(WorksheetFunction.RandBetween(1, 100)) = ""
   
7.     Loop
   
8.     [a2].Resize(10) = WorksheetFunction.Transpose(d.keys)
   
9.     Application.ScreenUpdating = True
   
10. End Sub
    

复制代码

生成1到100之间不重复的十个整数

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     Randomize
   
5.     arr = [a1].CurrentRegion
   
6.     For Each rn In arr
   
7.         d(rn) = ""
   
8.     Next rn
   
9.     For j = 1 To UBound(arr)
   
10.         For i = 1 To UBound(arr, 2)
    
11.             a = WorksheetFunction.RandBetween(0, d.Count - 1)
    
12.             arr(j, i) = d.keys()(a)
    
13.             d.Remove d.keys()(a)
    
14.         Next i
    
15.     Next j
    
16.     [G1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
17.     Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

对某区域内数据进行随机排序

凤翔时代

向您致敬，这是一种态度、更是一种奉献！！！

km122712

版主辛苦了，感谢分享！

陈功

感谢版主分享！

liulang0808

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Count <> 1 Then Exit Sub
   
3.     arr = Sheets(2).UsedRange
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For j = 2 To UBound(arr)
   
6.         If Len(arr(j, 1)) > 0 Then
   
7.             str1 = arr(j, 1)
   
8.         End If
   
9.         d(str1) = d(str1) & "," & arr(j, 2)
   
10.     Next j
    
11.     If Target.Column = 1 Then
    
12.         If Target.Row > 2 Then
    
13.             With Target.Validation
    
14.                 .Delete
    
15.                 .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    
16.                 xlBetween, Formula1:=Join(d.keys, ",")
    
17.             End With
    
18.         End If
    
19.     Else
    
20.         If Target.Column = 2 Then
    
21.             If Target.Row > 2 Then
    
22.             If d.exists(Cells(Target.Row, 1).Value) Then
    
23.                 With Target.Validation
    
24.                     .Delete
    
25.                     .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    
26.                     xlBetween, Formula1:=Mid(d(Cells(Target.Row, 1).Value), 2)
    
27.                 End With
    
28.             End If
    
29.         End If
    
30.         End If
    
31.     End If
    
32. End Sub
    

复制代码

二级菜单级联

jzl2606

向各位学习学习

LMY123

字典学习，感谢版主的分享