kimbal

§â³o¨â¬q©ñ¶iTHISWORKBOOK ©ÎMODULE

1. Public Sub recalc()
   
2.     Set dict = CreateObject("Scripting.Dictionary")
   
3.    
   
4.     Dim shtCurr As Worksheet
   
5.     Dim rng As Range
   
6.     For Each shtCurr In ThisWorkbook.Worksheets
   
7.         Set rng = Intersect(shtCurr.Columns(1), shtCurr.UsedRange)
   
8.         For Each c In rng.Cells
   
9.             If c <> "" Then
   
10.                 dict.Add Item:=c.Value, Key:=shtCurr.Name & "!" & c.Address
    
11.             End If
    
12.         Next
    
13.     Next
    
14.    
    
15.     Call SortDictionary(dict, 2)
    
16.    
    
17.     cnt = 1
    
18.     For Each kk In dict.keys
    
19.         Worksheets(Split(kk, "!")(0)).Range(Split(kk, "!")(1)).Value = cnt
    
20.         cnt = cnt + 1
    
21.     Next
    
22. End Sub
    
23. 
    
24. Public Function SortDictionary(ByRef objDict, ByRef intSort)
    
25.     Const dictKey = 1
    
26.     Const dictItem = 2
    
27. 
    
28.   ' declare our variables
    
29.   Dim strDict()
    
30.   Dim objKey
    
31.   Dim strKey, strItem
    
32.   Dim X, Y, Z
    
33. 
    
34.   ' get the dictionary count
    
35.   Z = objDict.Count
    
36. 
    
37.   ' we need more than one item to warrant sorting
    
38.   If Z > 1 Then
    
39.     ' create an array to store dictionary information
    
40.     ReDim strDict(Z, 2)
    
41.     X = 0
    
42.     ' populate the string array
    
43.     For Each objKey In objDict
    
44.         strDict(X, dictKey) = CStr(objKey)
    
45.         strDict(X, dictItem) = CStr(objDict(objKey))
    
46.         X = X + 1
    
47.     Next
    
48. 
    
49.     ' perform a a shell sort of the string array
    
50.     For X = 0 To (Z - 2)
    
51.       For Y = X To (Z - 1)
    
52.         'If StrComp(strDict(X, intSort), strDict(Y, intSort), vbTextCompare) > 0 Then
    
53.         If Val(strDict(X, intSort)) > Val(strDict(Y, intSort)) Then
    
54.             strKey = strDict(X, dictKey)
    
55.             strItem = strDict(X, dictItem)
    
56.             strDict(X, dictKey) = strDict(Y, dictKey)
    
57.             strDict(X, dictItem) = strDict(Y, dictItem)
    
58.             strDict(Y, dictKey) = strKey
    
59.             strDict(Y, dictItem) = strItem
    
60.         End If
    
61.       Next
    
62.     Next
    
63. 
    
64.     ' erase the contents of the dictionary object
    
65.     objDict.RemoveAll
    
66. 
    
67.     ' repopulate the dictionary with the sorted information
    
68.     For X = 0 To (Z - 1)
    
69.       objDict.Add strDict(X, dictKey), strDict(X, dictItem)
    
70.     Next
    
71. 
    
72.   End If
    
73. 
    
74. End Function

½Æ»s¥N½X

µM«á§â¥H¤U³o¬q©ñ¶i¨C­Ó¤u§@ªí

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     If Not (Intersect(Target, Columns(1)) Is Nothing) Then
   
3.         Application.EnableEvents = False
   
4.         Call recalc
   
5.         Application.EnableEvents = True
   
6.     End If
   
7. End Sub

½Æ»s¥N½X

¯d·N¹ï¤ñªº¤èªk¬O¥Î¼Æ¦r
Val(strDict(X, intSort)) > Val(strDict(Y, intSort))

°Ñ¦Ò
http://support.microsoft.com/kb/246067