Board logo

標題: 再問資料排序 [打印本頁]
作者: modelcrazyer    時間: 2012-10-16 22:04     標題: 再問資料排序

請問各位達人
我有三個工作表分別為
工作表1
A
5
8
工作表2
A
1
2
7
工作表3
3
6
現在想設計一個程式在刪掉工作表2的(A2)的2後
變成
工作表1
A
4
7
工作表2
A
1

6
工作表3
2
5
該怎麼寫比較好
作者: kimbal    時間: 2012-10-17 00:26

把這兩段放進THISWORKBOOK 或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

  24. Public Function SortDictionary(ByRef objDict, ByRef intSort)
  25.     Const dictKey = 1
  26.     Const dictItem = 2

  28.   ' declare our variables
  29.   Dim strDict()
  30.   Dim objKey
  31.   Dim strKey, strItem
  32.   Dim X, Y, Z

  34.   ' get the dictionary count
  35.   Z = objDict.Count

  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

  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

  64.     ' erase the contents of the dictionary object
  65.     objDict.RemoveAll

  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

  72.   End If

  74. End Function
複製代碼
然後把以下這段放進每個工作表
  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
複製代碼
留意對比的方法是用數字
Val(strDict(X, intSort)) > Val(strDict(Y, intSort))

參考
http://support.microsoft.com/kb/246067
作者: c_c_lai    時間: 2012-10-17 08:16

回復 2# kimbal
請教您：
為什麼把程式碼放進THISWORKBOOK時，在各工作表單內觸發 Change 時，
recalc 需指定 ThisWorkbook. 如圖示
  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 ThisWorkbook.recalc
  5.         Application.EnableEvents = True
  6.     End If
  7. End Sub
複製代碼
而如果放置於 Module1 內則不須指定
  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
複製代碼
謝謝指教！
作者: modelcrazyer    時間: 2012-10-17 21:48

謝謝kimbal及c_c_lai兩位,不過我資質駑鈍,反而是function看不懂,
想進一步請教,Z的變數是做甚麼用,
         For Each objKey In objDict
        strDict(X, dictKey) = CStr(objKey)
        strDict(X, dictItem) = CStr(objDict(objKey))
        X = X + 1
這一段更是完全不懂??
另外如果工作表變成
作表1
A
1-2
2-1
工作表2
A
1-3
2-1
3-1
工作表3
1-4
2-2
現在想設計一個程式在刪掉工作表2的(A2)的2後
變成
工作表1
A
1-2
2-1
工作表2
A
1-3

3-1
工作表3
1-4
2-1
程式又要如何改寫



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)