- ©«¤l
- 472
- ¥DÃD
- 5
- ºëµØ
- 0
- ¿n¤À
- 485
- ÂI¦W
- 0
- §@·~¨t²Î
- Windows
- ³nÅ骩¥»
- MS Office
- ¾\ŪÅv
- 100
- ©Ê§O
- ¨k
- ¨Ó¦Û
- »´ä
- µù¥U®É¶¡
- 2010-7-4
- ³Ì«áµn¿ý
- 2014-12-28
|
§â³o¨â¬q©ñ¶iTHISWORKBOOK ©ÎMODULE- Public Sub recalc()
- Set dict = CreateObject("Scripting.Dictionary")
-
- Dim shtCurr As Worksheet
- Dim rng As Range
- For Each shtCurr In ThisWorkbook.Worksheets
- Set rng = Intersect(shtCurr.Columns(1), shtCurr.UsedRange)
- For Each c In rng.Cells
- If c <> "" Then
- dict.Add Item:=c.Value, Key:=shtCurr.Name & "!" & c.Address
- End If
- Next
- Next
-
- Call SortDictionary(dict, 2)
-
- cnt = 1
- For Each kk In dict.keys
- Worksheets(Split(kk, "!")(0)).Range(Split(kk, "!")(1)).Value = cnt
- cnt = cnt + 1
- Next
- End Sub
- Public Function SortDictionary(ByRef objDict, ByRef intSort)
- Const dictKey = 1
- Const dictItem = 2
- ' declare our variables
- Dim strDict()
- Dim objKey
- Dim strKey, strItem
- Dim X, Y, Z
- ' get the dictionary count
- Z = objDict.Count
- ' we need more than one item to warrant sorting
- If Z > 1 Then
- ' create an array to store dictionary information
- ReDim strDict(Z, 2)
- X = 0
- ' populate the string array
- For Each objKey In objDict
- strDict(X, dictKey) = CStr(objKey)
- strDict(X, dictItem) = CStr(objDict(objKey))
- X = X + 1
- Next
- ' perform a a shell sort of the string array
- For X = 0 To (Z - 2)
- For Y = X To (Z - 1)
- 'If StrComp(strDict(X, intSort), strDict(Y, intSort), vbTextCompare) > 0 Then
- If Val(strDict(X, intSort)) > Val(strDict(Y, intSort)) Then
- strKey = strDict(X, dictKey)
- strItem = strDict(X, dictItem)
- strDict(X, dictKey) = strDict(Y, dictKey)
- strDict(X, dictItem) = strDict(Y, dictItem)
- strDict(Y, dictKey) = strKey
- strDict(Y, dictItem) = strItem
- End If
- Next
- Next
- ' erase the contents of the dictionary object
- objDict.RemoveAll
- ' repopulate the dictionary with the sorted information
- For X = 0 To (Z - 1)
- objDict.Add strDict(X, dictKey), strDict(X, dictItem)
- Next
- End If
- End Function
½Æ»s¥N½X µM«á§â¥H¤U³o¬q©ñ¶i¨CÓ¤u§@ªí- Private Sub Worksheet_Change(ByVal Target As Range)
- If Not (Intersect(Target, Columns(1)) Is Nothing) Then
- Application.EnableEvents = False
- Call recalc
- Application.EnableEvents = True
- End If
- End Sub
½Æ»s¥N½X ¯d·N¹ï¤ñªº¤èªk¬O¥Î¼Æ¦r
Val(strDict(X, intSort)) > Val(strDict(Y, intSort))
°Ñ¦Ò
http://support.microsoft.com/kb/246067 |
|