Hsieh

回復 16# asus103

1. Sub Dic_Sort()
   
2. Dim C()
   
3. Set d = CreateObject("Scripting.Dictionary") '
   
4. Set d1 = CreateObject("Scripting.Dictionary") '同索引項目數量計數器
   
5. '(注意)工作表1跟工作表2的資料列數要相同
   
6. a = Sheets(1).Range("A1").CurrentRegion: B = Sheets(2).Range("A1").CurrentRegion '寫入A、B陣列內容
   
7. For Each y In Array(a, B) '以迴圈順序讀入A、B陣列到字典物件
   
8.    For i = LBound(y, 2) To UBound(y, 2)
   
9.      d(y(1, i) + d1(y(1, i)) * 0.1) = Application.Transpose(Application.Index(y, , i)) '因為索引值都是整數，所以索引值加計數的0.1倍當成新索引值，避免與其他索引值重複，對應2列的值
   
10.      d1(y(1, i)) = d1(y(1, i)) + 1 '同索引值計數
    
11.    Next
    
12. Next
    
13. Do Until d.Count = 0 '進行迴圈，直到字典內容數量為0跳出迴圈
    
14.    ky = Application.Small(d.keys, 1) '得到索引值陣列中最小值
    
15.    'ky = Application.Min(d.keys) '得到索引值陣列中最小值，亦可使用MIN函數
    
16.    ReDim Preserve C(s)
    
17.    C(s) = d(ky) '將最小值的內容存入陣列
    
18.    s = s + 1
    
19.    d.Remove ky '移除字典中最小值的項目，此時字典內容數量會減少1個
    
20. Loop
    
21. Sheets(3).[A1].Resize(UBound(a, 1), s) = Application.Transpose(C) '原本C陣列可視為s列(陣列A的列數)欄，所以轉置後成為(陣列A的列數)列s欄，寫入工作表
    
22. Set d = Nothing '釋放物件
    
23. Set d1 = Nothing '釋放物件
    
24. End Sub

複製代碼

Array_Sort.zip (11.64 KB)

下載次數: 8

2011-1-15 21:40

asus103

感謝Hsieh、FAlonso兩位大大
我從這個討論的過程中收穫很多
會再花時間好好吸收其中精華
而且程式碼值得典藏，以後必然尚有機會用到

感謝再三

Andy2483

回復 21# Hsieh


    謝謝前輩,謝謝論壇
後學藉此帖練習陣列在字典裡吞吐之間編輯陣列值與 儲存格同字元數橫向排序,練習方案如下
請前輩們指教

資料表(工作表1):

下載 (55.62 KB)

2023-3-28 13:00

資料表(工作表2):

下載 (53.9 KB)

2023-3-28 13:01

結果表(工作表3):

下載 (80.29 KB)

2023-3-28 13:01

Option Explicit
Sub TEST_2()
Application.ScreenUpdating = False
Dim Y, N&, i&, j&, A, C%
Set Y = CreateObject("Scripting.Dictionary")
Sheets(3).UsedRange.Clear
For i = 1 To 2
   Y("表" & i) = Sheets(i).Range("A1").CurrentRegion: A = Y("表" & i)
   Y(i & "/R") = UBound(A): Y(i & "/C") = UBound(A, 2)
   For j = 1 To Y(i & "/C")
      N = N + 1: A(1, j) = Format(A(1, j), "000") & "|" & Format(N, "000")
   Next
   Y("表" & i) = A
Next
Sheets(3).[A1].Resize(Y("1/R"), Y("1/C")) = Y("表1")
Sheets(3).[A1].Item(1, Y("1/C") + 1).Resize(Y("2/R"), Y("2/C")) = Y("表2")
With Sheets(3).UsedRange
   .Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo, _
   Orientation:=xlLeftToRight
   Intersect([1:1], .Cells).Replace "|*", "", Lookat:=xlPart
End With
Set Y = Nothing
End Sub