- 帖子
- 472
- 主題
- 5
- 精華
- 0
- 積分
- 485
- 點名
- 0
- 作業系統
- Windows
- 軟體版本
- MS Office
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 香港
- 註冊時間
- 2010-7-4
- 最後登錄
- 2014-12-28
|
2#
發表於 2012-10-17 00:26
| 只看該作者
把這兩段放進THISWORKBOOK 或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
- 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
Val(strDict(X, intSort)) > Val(strDict(Y, intSort))
參考
http://support.microsoft.com/kb/246067 |
|
發表於 2012-10-16 22:04
| 
