asus103

Hsieh大大您好
對不起，我看不大懂
可以麻煩您解釋一下嗎?

我如果要用到我的程式中
是不是要插入1、3、5行呢?
第1行是否一定得在整個模組的最上方呢?

asus103

回復 10# Hsieh
感謝您Hsieh大大

非常感激您的協助
我想我大概需要花一段時間來消化最近您教的東西

謝謝您

FAlonso

回復 1# asus103

1. Sub merge_rank()
   
2. Dim myobject As Object
   
3. Dim myrange As Range
   
4. Dim i As Integer
   
5. 
   
6. Set myobject = CreateObject("scripting.dictionary")
   
7. 
   
8. For i = 1 To 2
   
9. With Worksheets("sheet" & i)
   
10. For Each myrange In .Range(.[a1], .[a1].End(xlToRight))
    
11. myobject(myrange.Value) = myrange.Offset(1).Value
    
12. Next
    
13. End With
    
14. Next
    
15. 
    
16. With Sheet3
    
17. For i = 1 To myobject.Count
    
18. .Cells(1, i).Value = Application.Small(myobject.keys, i)
    
19. .Cells(2, i).Value = myobject.Item(Application.Small(myobject.keys, i))
    
20. Next
    
21. End With
    
22. 
    
23. Set myobject = Nothing
    
24. 
    
25. End Sub

複製代碼

Hsieh

回復 13# FAlonso
若考慮索引值會重複的情形(第一列相同，但第二列對應值不同)
如圖的資料

下載 (5.03 KB)

2011-1-14 20:35

您會如何解決?
Array_Sort.zip (10.21 KB)

下載次數: 5

2011-1-14 20:20

1. Sub Dic_Sort()
   
2. Dim C()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Set d1 = CreateObject("Scripting.Dictionary")
   
5. A = Sheets(1).[A1:J2]: B = Sheets(2).[A1:J2]
   
6. For Each y In Array(A, B)
   
7.    For i = LBound(y, 2) To UBound(y, 2)
   
8.      d(y(1, i) + d1(y(1, i)) * 0.1) = Array(y(1, i), y(2, i))
   
9.      d1(y(1, i)) = d1(y(1, i)) + 1
   
10.    Next
    
11. Next
    
12. Do Until d.Count = 0
    
13.    ky = Application.Small(d.keys, 1)
    
14.    ReDim Preserve C(s)
    
15.    C(s) = d(ky)
    
16.    s = s + 1
    
17.    d.Remove ky
    
18. Loop
    
19. Sheets(3).[A1].Resize(2, s) = Application.Transpose(C)
    
20. Set d = Nothing
    
21. Set d1 = Nothing
    
22. End Sub

複製代碼

FAlonso

回復 14# Hsieh
下載不到

asus103

回復 13# FAlonso

感謝您FAlonso大大
您的IDEA的確很妙，深感佩服
我會根據這個想法再來看看我的程式的改進空間
我的陣列中第1維的確是唯一
但是每一個資料之下卻不只1個
即
A  8 4 6               B 7 5 3 9                C 3 4 5 6 7 8 9
    3 4 5                  4 2 1 3                   1 4 2 5 4 3 3
    1 2 3                  5 4 3 2                   . . . . . . . . . ..

非常感謝您的協助

FAlonso

回復 14# Hsieh

1. Sub merge_rank()
   
2. Dim myobject As Object, myobject2 As Object
   
3. Dim myrange As Range
   
4. Dim i As Integer, j As Integer
   
5. 
   
6. Set myobject = CreateObject("scripting.dictionary")
   
7. Set myobject2 = CreateObject("scripting.dictionary")
   
8. 
   
9. With Sheet4
   
10. For Each myrange In .Range(.[a1], .[a1].End(xlToRight))
    
11. myobject(myrange.Value) = myobject(myrange.Value) + 1      'myrange.value為第1 row某數字,myobject作為計數器
    
12. myobject2(myrange.Value & "," & myobject(myrange.Value)) = myrange.Offset(1).Value  myobject2輸入第2 row的數字(index為myrange.Value & "," & myobject(myrange.Value,即數字及其出現次數)
    
13. Next
    
14. End With
    
15. 
    
16. With Sheet5
    
17. .Activate
    
18. .Range("a1").Activate
    
19. For i = 1 To myobject.Count   '先數有多少筆不同的資料
    
20. For j = 1 To myobject(Application.Small(myobject.keys, i))       '先排列,再找出其出現次數
    
21. ActiveCell.Value = Application.Small(myobject.keys, i)            
    
22. ActiveCell.Offset(1, 0).Value = myobject2(Application.Small(myobject.keys, i) & "," & j)
    
23. ActiveCell.Offset(0, 1).Select
    
24. Next
    
25. Next
    
26. End With
    
27. 
    
28. Set myobject = Nothing
    
29. Set myobject2 = Nothing
    
30. 
    
31. End Sub

複製代碼

Hsieh

回復 17# FAlonso
作法思考邏輯一樣，排序是用SMALL函數，可將KEY一一移除，取最小值，所以若用MIN也是同樣效果

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

複製代碼

FAlonso

看第20頁,那個是最終程式

FAlonso

1. Sub merge_rank2()
   
2. Dim myobject As Object, myobject2 As Object
   
3. Dim myrange As Range
   
4. Dim i As Integer, j As Integer, k As Integer, myrow As Integer
   
5. Dim mykey
   
6. 
   
7. Set myobject = CreateObject("scripting.dictionary")
   
8. Set myobject2 = CreateObject("scripting.dictionary")
   
9. 
   
10. myrow = Sheet4.Range("A65536").End(xlUp).Row
    
11. 
    
12. With Sheet4
    
13. For Each myrange In .Range(.[a1], .[a1].End(xlToRight))
    
14. myobject(myrange.Value) = myobject(myrange.Value) + 1
    
15. For j = 2 To myrow
    
16. myobject2(myrange.Value & "," & myobject(myrange.Value) & "," & j) = myrange.Offset(j - 1).Value
    
17. Next
    
18. Next
    
19. End With
    
20. 
    
21. With Sheet5
    
22. .Activate
    
23. .Range("a1").Activate
    
24. For i = 1 To myobject.Count
    
25. For j = 1 To myobject(Application.Small(myobject.keys, i))
    
26. ActiveCell.Value = Application.Small(myobject.keys, i)
    
27. For k = 2 To myrow
    
28. ActiveCell.Offset(k - 1, 0).Value = myobject2(Application.Small(myobject.keys, i) & "," & j & "," & k)
    
29. Next
    
30. ActiveCell.Offset(0, 1).Select
    
31. Next
    
32. Next
    
33. End With
    
34. 
    
35. Set myobject = Nothing
    
36. Set myobject2 = Nothing
    
37. 
    
38. End Sub

複製代碼

這個是優化程式,第一行重覆也可使用
我到此為止了.....