Board logo

標題: [發問]將兩陣列依順序合併問題 [打印本頁]
作者: asus103    時間: 2011-1-13 09:33     標題: [發問]將兩陣列依順序合併問題

各位大大您們好
如果想將兩陣列依由小而大順序合併問題
如：
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
將A，B兩陣列合併成C陣列，並將其餘相對應資料抄錄，
應該如何解決

感謝各位的協助
作者: Hsieh    時間: 2011-1-13 10:49

回復 1# asus103
有些數值跟你A、B陣列取得方式有關
以儲存格範圍為陣列為例
  1. Sub nn()
  2. Dim Ar(), Ay(), C(), A, B
  3. A = [B1:D2]: B = [F1:I2]
  4. For i = LBound(A, 1) To UBound(A, 1)
  5.    For j = LBound(A, 2) To UBound(A, 2)
  6.    ReDim Preserve Ar(s)
  7.    Ar(s) = A(i, j) '取得A陣列
  8.    s = s + 1
  9.    Next
  10.    For j = LBound(B, 2) To UBound(B, 2)
  11.    ReDim Preserve Ar(s)
  12.    Ar(s) = B(i, j) '取得B陣列
  13.    s = s + 1
  14.    Next
  15.    ReDim Ay(s)
  16.    For j = 0 To UBound(Ar)
  17.      Ay(j) = Application.Small(Ar, j + 1) '排序
  18.    Next
  19.    ReDim Preserve C(k)
  20.    C(k) = Ay: s = 0: Erase Ay '加入資料到C陣列，把暫存陣列清除
  21.    k = k + 1
  22. Next
  23. [K1].Resize(k, UBound(A, 2) + UBound(B, 2)) = Application.Transpose(Application.Transpose(C))
  24. End Sub
複製代碼
作者: asus103    時間: 2011-1-13 13:19

回復 2# Hsieh

Hsieh大大您好

我這次的重點落在『並將其餘相對應資料抄錄』，也就是第2維資料要跟著原來第1維資料

原先已有了兩個陣列(A、B)合併成C之後，第1維按由小而大順序，第2維須跟著原來的第1維
例如：
A陣列是A班的成績、姓名，B陣列是B班的成績、姓名
想要按照成績高低合併成新陣列，但成績須對到原來的人

感謝大大的回覆，
由其中我要學到處理工作表資料與陣列間的不同方式和想法
作者: Hsieh    時間: 2011-1-13 13:30

回復 3# asus103

不懂你所謂
並將其餘相對應資料抄錄
請上傳你的範例說明
作者: asus103    時間: 2011-1-13 13:42

回復 4# Hsieh
Hsieh大大您好
對不起，是我辭不達意
附上範例檔
感謝您
[attach]4392[/attach]
作者: Hsieh    時間: 2011-1-13 16:34

本帖最後由 Hsieh 於 2011-1-13 22:28 編輯

回復 5# asus103
  1. Sub ex()
  2. Dim C()
  3. Open "test.txt" For Output As #1 '產生暫存檔
  4. A = [B1:D2]: B = [F1:I2]
  5. For i = LBound(A, 2) To UBound(A, 2)
  6. Print #1, A(1, i) & "," & A(2, i)
  7. Next
  8. For i = LBound(B, 2) To UBound(B, 2)
  9. Print #1, B(1, i) & "," & B(2, i)
  10. Next
  11. Close #1
  12. Shell "sort / " & "test.txt" & " /o " & "temp.txt" '產生排序暫存檔
  13. '偵測直到檔案產生,再繼續後面的動作
  14. While Dir("temp.txt") = ""
  15. Wend
  16. Open "temp.txt" For Input As #1
  17. Do Until EOF(1)
  18. Line Input #1, mystr
  19. ReDim Preserve C(s)
  20. C(s) = Split(mystr, ",")
  21. s = s + 1
  22. Loop
  23. Close #1
  24. Kill "test.txt" '刪除暫存檔
  25. Kill "temp.txt" '刪除排序暫存檔
  26. [B12].Resize(2, s) = Application.Transpose(C)
  27. End Sub
複製代碼
sort指令是Windows原本就有的DOS指令，用於排序純文字檔。
以上程式通過Windows7+Excel2010測試；
若在你的電腦執行有誤，請確認你的電腦裡有 sort.exe 這個執行檔。
作者: asus103    時間: 2011-1-13 16:45

回復 6# Hsieh
感謝您Hsieh大大
我測試過了winxp、office2007能正常工作
跟文字檔間的互動是我之前比較少碰，但正好是我自己規劃下一階段的學習目標
我需要多花一點時間去研究他，若有問題再向您請教
感謝您
作者: Hsieh    時間: 2011-1-13 17:39

本帖最後由 Hsieh 於 2011-1-13 18:45 編輯

回復 7# asus103
  1. Sub yy() '氣泡排序
  2. Dim Ar(), Ay()
  3. A = [B1:D2]: B = [F1:I2]
  4. For Each y In Array(A, B)
  5. For i = LBound(y, 2) To UBound(y, 2)
  6. ReDim Preserve Ar(s)
  7. ReDim Preserve Ay(s)
  8.   Ar(s) = y(1, i)
  9.   Ay(s) = y(2, i)
  10.   s = s + 1
  11. Next
  12. Next
  13. For i = 0 To UBound(Ar)
  14.     For j = 0 To UBound(Ar) - 1
  15.        If Ar(j + 1) < Ar(j) Then '遞增
  16.      'If Ar(j + 1) > Ar(j) Then  '遞減
  17.       temp = Ar(j)
  18.       temp1 = Ay(j)
  19.       Ar(j) = Ar(j + 1)
  20.       Ar(j + 1) = temp
  21.       Ay(j) = Ay(j + 1)
  22.       Ay(j + 1) = temp1
  23.       
  24.     End If
  25.     Next
  26. Next
  27. [B15].Resize(, s) = Ar
  28. [B16].Resize(, s) = Ay
  29. End Sub
複製代碼
作者: asus103    時間: 2011-1-13 20:32

本帖最後由 asus103 於 2011-1-13 20:34 編輯

回復 8# Hsieh
感謝您Hsieh大大
又提供我另一個思考方式

可以另外再請教您有關"Delay"的用法嗎?
VBA說明我看不甚懂
不知道如何控制延遲時間，
如果在一回圈中每一次延遲0.5秒，其語法為何
謝謝
作者: Hsieh    時間: 2011-1-13 21:05

本帖最後由 Hsieh 於 2011-1-13 22:26 編輯

回復 9# asus103
一般模組
  1. Declare Sub Sleep Lib "kernel32" (ByVal dwmilliseconds As Long) '宣告API的SLEEP函數
  2. Sub nn()
  3. t = Timer '開始計時
  4. For i = 1 To 10
  5.   Sleep 500  '延遲500/1000秒
  6. Next
  7. MsgBox "延遲" & Timer - t & "秒"  "每次延遲0.5秒，十次延遲後共延遲?秒
  8. End Sub
複製代碼
作者: asus103    時間: 2011-1-13 21:47

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

我如果要用到我的程式中
是不是要插入1、3、5行呢?
第1行是否一定得在整個模組的最上方呢?
作者: asus103    時間: 2011-1-14 08:36

回復 10# Hsieh
感謝您Hsieh大大

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

謝謝您
作者: FAlonso    時間: 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
複製代碼
作者: Hsieh    時間: 2011-1-14 16:05

本帖最後由 Hsieh 於 2011-1-15 11:58 編輯

回復 13# FAlonso
若考慮索引值會重複的情形(第一列相同，但第二列對應值不同)
如圖的資料[attach]4403[/attach]
您會如何解決?
[attach]4401[/attach]
  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    時間: 2011-1-14 20:28

回復 14# Hsieh
下載不到
作者: asus103    時間: 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                   . . . . . . . . . ..

非常感謝您的協助
作者: FAlonso    時間: 2011-1-15 11:49

回復 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
複製代碼
作者: Hsieh    時間: 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
複製代碼
作者: FAlonso    時間: 2011-1-15 12:45

本帖最後由 FAlonso 於 2011-1-15 14:13 編輯

看第20頁,那個是最終程式
作者: FAlonso    時間: 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
複製代碼
這個是優化程式,第一行重覆也可使用
我到此為止了.....
作者: Hsieh    時間: 2011-1-15 21:40

回復 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
複製代碼
[attach]4408[/attach]
作者: asus103    時間: 2011-1-16 09:51

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

感謝再三
作者: Andy2483    時間: 2023-3-28 13:03

回復 21# Hsieh


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

資料表(工作表1):
[attach]36050[/attach]
資料表(工作表2):
[attach]36051[/attach]

結果表(工作表3):
[attach]36052[/attach]

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



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