123
返回列表 上一主題 發帖

[發問]將兩陣列依順序合併問題

asus103

帖子
77 
主題
11 
精華
0 
積分
118 
點名
0  
作業系統
winXP 
軟體版本
office2007 
閱讀權限
20 
性別
男 
註冊時間
2010-12-24 
最後登錄
2011-3-2 
11# 跳轉到 »
發表於 2011-1-13 21:47 | 只看該作者
[版主管理留言]
  • Hsieh(2011-1-13 23:15): 10#已標示註解

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

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

TOP

asus103

帖子
77 
主題
11 
精華
0 
積分
118 
點名
0  
作業系統
winXP 
軟體版本
office2007 
閱讀權限
20 
性別
男 
註冊時間
2010-12-24 
最後登錄
2011-3-2 
12#
發表於 2011-1-14 08:36 | 只看該作者
回復 10# Hsieh
感謝您Hsieh大大

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

謝謝您
ASUS

TOP

FAlonso

帖子
135 
主題
19 
精華
0 
積分
165 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
性別
男 
來自
香港 
註冊時間
2010-12-9 
最後登錄
2012-8-27 
13#
發表於 2011-1-14 15:11 | 只看該作者
回復 1# asus103
  1. Sub merge_rank()
  2. Dim myobject As Object
  3. Dim myrange As Range
  4. Dim i As Integer

  6. Set myobject = CreateObject("scripting.dictionary")

  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

  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

  23. Set myobject = Nothing

  25. End Sub
複製代碼
80 字節以內
不支持自定義 Discuz! 代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
254  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-23 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
14#
發表於 2011-1-14 16:05 | 只看該作者
本帖最後由 Hsieh 於 2011-1-15 11:58 編輯

回復 13# FAlonso
若考慮索引值會重複的情形(第一列相同，但第二列對應值不同)
如圖的資料
您會如何解決?
Array_Sort.zip (10.21 KB)
  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
複製代碼
學海無涯_不恥下問

TOP

FAlonso

帖子
135 
主題
19 
精華
0 
積分
165 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
性別
男 
來自
香港 
註冊時間
2010-12-9 
最後登錄
2012-8-27 
15#
發表於 2011-1-14 20:28 | 只看該作者
[版主管理留言]
  • Hsieh(2011-1-14 20:32): 先提出你的解決方式，再解開權限

回復 14# Hsieh
下載不到
80 字節以內
不支持自定義 Discuz! 代碼

TOP

asus103

帖子
77 
主題
11 
精華
0 
積分
118 
點名
0  
作業系統
winXP 
軟體版本
office2007 
閱讀權限
20 
性別
男 
註冊時間
2010-12-24 
最後登錄
2011-3-2 
16#
發表於 2011-1-14 20:50 | 只看該作者
本帖最後由 asus103 於 2011-1-15 03:15 編輯

回復 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                   . . . . . . . . . ..

非常感謝您的協助
ASUS

TOP

FAlonso

帖子
135 
主題
19 
精華
0 
積分
165 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
性別
男 
來自
香港 
註冊時間
2010-12-9 
最後登錄
2012-8-27 
17#
發表於 2011-1-15 11:49 | 只看該作者
[版主管理留言]
  • Hsieh(2011-1-15 11:59): 已開放下載，程式碼也顯示了 參考看看 多謝參與討論

回復 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

  6. Set myobject = CreateObject("scripting.dictionary")
  7. Set myobject2 = CreateObject("scripting.dictionary")

  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

  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

  28. Set myobject = Nothing
  29. Set myobject2 = Nothing

  31. End Sub
複製代碼
80 字節以內
不支持自定義 Discuz! 代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
254  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-23 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
18#
發表於 2011-1-15 12:04 | 只看該作者
本帖最後由 Hsieh 於 2011-1-15 18:23 編輯

回復 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
複製代碼
學海無涯_不恥下問

TOP

FAlonso

帖子
135 
主題
19 
精華
0 
積分
165 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
性別
男 
來自
香港 
註冊時間
2010-12-9 
最後登錄
2012-8-27 
19#
發表於 2011-1-15 12:45 | 只看該作者
本帖最後由 FAlonso 於 2011-1-15 14:13 編輯

看第20頁,那個是最終程式
80 字節以內
不支持自定義 Discuz! 代碼

TOP

FAlonso

帖子
135 
主題
19 
精華
0 
積分
165 
點名
0  
作業系統
XP 
軟體版本
2003 
閱讀權限
20 
性別
男 
來自
香港 
註冊時間
2010-12-9 
最後登錄
2012-8-27 
20#
發表於 2011-1-15 14:01 | 只看該作者
  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

  7. Set myobject = CreateObject("scripting.dictionary")
  8. Set myobject2 = CreateObject("scripting.dictionary")

  10. myrow = Sheet4.Range("A65536").End(xlUp).Row

  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

  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

  35. Set myobject = Nothing
  36. Set myobject2 = Nothing

  38. End Sub
複製代碼
這個是優化程式,第一行重覆也可使用
我到此為止了.....
80 字節以內
不支持自定義 Discuz! 代碼

TOP

        靜思自在 : 稻穗結得越飽滿，越會往下垂，一個人越有成就，就要越有謙沖的胸襟。
123
返回列表 上一主題