[發問]將兩陣列依順序合併問題 - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » [發問]將兩陣列依順序合併問題

返回列表下一主題上一主題發帖

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

中學生 Rank: 2

帖子: 135
主題: 19
精華: 0
積分: 165
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: 香港
註冊時間: 2010-12-9
最後登錄: 2012-8-27

1^# 跳轉到 »

發表於 2011-1-14 15:11 | 顯示全部帖子

回復 1# asus103

Sub merge_rank()
Dim myobject As Object
Dim myrange As Range
Dim i As Integer
Set myobject = CreateObject("scripting.dictionary")
For i = 1 To 2
With Worksheets("sheet" & i)
For Each myrange In .Range(.[a1], .[a1].End(xlToRight))
myobject(myrange.Value) = myrange.Offset(1).Value
Next
End With
Next
With Sheet3
For i = 1 To myobject.Count
.Cells(1, i).Value = Application.Small(myobject.keys, i)
.Cells(2, i).Value = myobject.Item(Application.Small(myobject.keys, i))
Next
End With
Set myobject = Nothing
End Sub

複製代碼

80 字節以內
不支持自定義 Discuz! 代碼

中學生 Rank: 2

帖子: 135
主題: 19
精華: 0
積分: 165
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: 香港
註冊時間: 2010-12-9
最後登錄: 2012-8-27

2^#

發表於 2011-1-14 20:28 | 顯示全部帖子

[版主管理留言]

Hsieh(2011-1-14 20:32): 先提出你的解決方式，再解開權限

回復 14# Hsieh
下載不到

80 字節以內
不支持自定義 Discuz! 代碼

中學生 Rank: 2

帖子: 135
主題: 19
精華: 0
積分: 165
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: 香港
註冊時間: 2010-12-9
最後登錄: 2012-8-27

3^#

發表於 2011-1-15 11:49 | 顯示全部帖子

[版主管理留言]

Hsieh(2011-1-15 11:59): 已開放下載，程式碼也顯示了參考看看多謝參與討論

回復 14# Hsieh

Sub merge_rank()
Dim myobject As Object, myobject2 As Object
Dim myrange As Range
Dim i As Integer, j As Integer
Set myobject = CreateObject("scripting.dictionary")
Set myobject2 = CreateObject("scripting.dictionary")
With Sheet4
For Each myrange In .Range(.[a1], .[a1].End(xlToRight))
myobject(myrange.Value) = myobject(myrange.Value) + 1 'myrange.value為第1 row某數字,myobject作為計數器
myobject2(myrange.Value & "," & myobject(myrange.Value)) = myrange.Offset(1).Value myobject2輸入第2 row的數字(index為myrange.Value & "," & myobject(myrange.Value,即數字及其出現次數)
Next
End With
With Sheet5
.Activate
.Range("a1").Activate
For i = 1 To myobject.Count '先數有多少筆不同的資料
For j = 1 To myobject(Application.Small(myobject.keys, i)) '先排列,再找出其出現次數
ActiveCell.Value = Application.Small(myobject.keys, i)
ActiveCell.Offset(1, 0).Value = myobject2(Application.Small(myobject.keys, i) & "," & j)
ActiveCell.Offset(0, 1).Select
Next
Next
End With
Set myobject = Nothing
Set myobject2 = Nothing
End Sub

複製代碼

80 字節以內
不支持自定義 Discuz! 代碼

中學生 Rank: 2

帖子: 135
主題: 19
精華: 0
積分: 165
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: 香港
註冊時間: 2010-12-9
最後登錄: 2012-8-27

4^#

發表於 2011-1-15 12:45 | 顯示全部帖子

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

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

80 字節以內
不支持自定義 Discuz! 代碼

中學生 Rank: 2

帖子: 135
主題: 19
精華: 0
積分: 165
點名: 0
作業系統: XP
軟體版本: 2003
閱讀權限: 20
性別: 男
來自: 香港
註冊時間: 2010-12-9
最後登錄: 2012-8-27

5^#

發表於 2011-1-15 14:01 | 顯示全部帖子

Sub merge_rank2()
Dim myobject As Object, myobject2 As Object
Dim myrange As Range
Dim i As Integer, j As Integer, k As Integer, myrow As Integer
Dim mykey
Set myobject = CreateObject("scripting.dictionary")
Set myobject2 = CreateObject("scripting.dictionary")
myrow = Sheet4.Range("A65536").End(xlUp).Row
With Sheet4
For Each myrange In .Range(.[a1], .[a1].End(xlToRight))
myobject(myrange.Value) = myobject(myrange.Value) + 1
For j = 2 To myrow
myobject2(myrange.Value & "," & myobject(myrange.Value) & "," & j) = myrange.Offset(j - 1).Value
Next
Next
End With
With Sheet5
.Activate
.Range("a1").Activate
For i = 1 To myobject.Count
For j = 1 To myobject(Application.Small(myobject.keys, i))
ActiveCell.Value = Application.Small(myobject.keys, i)
For k = 2 To myrow
ActiveCell.Offset(k - 1, 0).Value = myobject2(Application.Small(myobject.keys, i) & "," & j & "," & k)
Next
ActiveCell.Offset(0, 1).Select
Next
Next
End With
Set myobject = Nothing
Set myobject2 = Nothing
End Sub

複製代碼

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

80 字節以內
不支持自定義 Discuz! 代碼

靜思自在 : 愛不是要求對方，而是要由自身的付出。

返回列表下一主題上一主題