返回列表 上一主題 發帖

[發問] (字典物件)查詢並對齊資料列問題

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2016-11-11 14:56 | 只看該作者

[發問] (字典物件)查詢並對齊資料列問題

各位前輩好,
小弟目前練習字典物件時遇到一個問題,
附上檔案以供前輩參考:
20161111-查詢並對齊橫列問題.zip (7.94 KB)

問題以文字簡單說明如下:

A欄與B欄為資料總表,依序排列,
A欄儲存格資料與B欄儲存格資料具有相對關係.


C欄與D欄的資料是取自A欄B欄,但是順序經過打亂.
E欄與F欄亦同.

現在是希望可以將資料排序後,將資料的橫列位置對齊A欄與B欄的位置.

用文字說明可能不易理解,
還請前輩參考附檔的"期望結果示意"頁籤.


這個練習問題是改編自以下網址的實例7:
http://club.excelhome.net/thread-868892-1-1.htmlz

該論壇有板友附上參考解答如下,
我用電腦版看不到網站的圖片,
推測可能是從第三橫列開始,與小弟此篇的附檔有些差異,僅供參考:
  1. Private Sub CommandButton1_Click()  ‘by:oobird
  2. Dim d As Object, rng, i%, j%, arr
  3. Set d = CreateObject("Scripting.Dictionary")
  4. rng = Range("a3:f" & [a65536].End(xlUp).Row)
  5. ReDim arr(1 To UBound(rng), 1 To 4)
  6. For i = 1 To UBound(rng)   
  7. d(CStr(rng(i, 1))) = i
  8. Next i
  9. For j = 3 To 5 Step 2
  10. For i = 1 To Cells(65536, j).End(xlUp).Row - 2
  11. If d(CStr(rng(i, j))) <> "" Then
  12. arr(d(CStr(rng(i, j))), j - 2) = rng(i, j)     
  13. arr(d(CStr(rng(i, j))), j - 1) = rng(i, j + 1)
  14. End If
  15. Next i
  16. Next j
  17. [c3].Resize(UBound(rng), 4) = arr
  18. End Sub   
複製代碼
因為知道論壇上的前輩應該有其他方式的解法,
所以小弟斗膽上來發問,可以的話還望前輩不吝解答,感謝.
收藏 分享

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
2#
發表於 2016-11-11 15:21 | 只看該作者
真的很抱歉,
"原始資料"分頁跟
"期望結果示意"分頁的A欄跟B欄應該是完全一樣的,
"期望結果示意"分頁的第19橫列是多打的,而第一空白橫列應予刪除而未刪除,
造成困擾不好意思.

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
3#
發表於 2016-11-12 08:40 | 只看該作者
回復 2# greetingsfromtw
  1. Sub Ex2()
  2.     Dim arr As Variant, cts As Integer
  3.     Dim ln As Integer, cn As Integer
  4.    
  5.     With Sheets("原始資料")
  6.         cts = Application.CountA(.Range("A:A"))
  7.         ReDim arr(1 To cts - 1, 1 To 4)
  8.         
  9.         For ln = 2 To cts
  10.             For cn = 3 To 5 Step 2
  11.                 If .Cells(ln, cn) <> "" Then
  12.                     arr(Asc(.Cells(ln, cn).Value) - 64, cn - 2) = .Cells(ln, cn)
  13.                     arr(Asc(.Cells(ln, cn).Value) - 64, cn - 1) = .Cells(ln, cn + 1)
  14.                 End If
  15.             Next cn
  16.         Next ln

  18.         .[G2].Resize(cts - 1, 4) = arr
  19.     End With
  20. End Sub
複製代碼

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
4#
發表於 2016-11-12 09:11 | 只看該作者
回復 3# c_c_lai


    十分感謝c_c_lai前輩提供解答,小弟再研究一下

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
5#
發表於 2016-11-12 10:13 | 只看該作者
  1. Sub TEST()
  2. Dim Arr, D, T$, R&, C&
  3. Arr = Range("A2:F" & [A65536].End(3).Row)
  4. Set D = CreateObject("Scripting.Dictionary")
  5. For C = 1 To UBound(Arr, 2) Step 2
  6.     For R = 1 To UBound(Arr)
  7.         T = Arr(R, C): If T = "" Then GoTo 101
  8.         If C = 1 Then D(T) = R: GoTo 101
  9.         Arr(R, C) = "": Arr(R, C + 1) = ""
  10.         Arr(D(T), C) = T
  11.         Arr(D(T), C + 1) = Arr(D(T), 2)
  12. 101: Next
  13. Next
  14. [期望結果示意!A3:F3].Resize(UBound(Arr)) = Arr
  15. End Sub
複製代碼

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
6#
發表於 2016-11-13 21:27 | 只看該作者
回復 5# 准提部林

非常感謝淮提部林前輩願意費心指點,一直以來承蒙前輩無私指導,真的非常感激.
再次感謝.

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
7#
發表於 2016-11-15 21:48 | 只看該作者
回復 5# 准提部林

淮提部林前輩您好,不好意思冒昧問一下,

前輩所提供程式碼的其他部份小弟勉強能領會一二,

只是關於第三行:
Arr = Range("A2:F" & [A65536].End(3).Row)

其中數字3這個部份,小弟不明其意,
雖然知道可取代xlUP,但是用1,2,4去修改程式碼進行試驗,卻無法達到取代xlToRight等其他方向的效果,
而是變成選取整欄或是整列,
小弟斗膽,懇請前輩不吝指點,感謝.

TOP

准提部林

帖子
2843 
主題
10 
精華
0 
積分
2899 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2025-6-27 
8#
發表於 2016-11-15 22:24 | 只看該作者
回復 7# greetingsfromtw


不習慣用數字, 就用原來熟用的就好, 不須煩這個!
由下而上, 起點就要取下方的儲存格往上找,
由上而下, 起點就相反,
左/右方向亦同, 多參幾次, 做到懂為止!

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
9#
發表於 2016-11-15 22:54 | 只看該作者
回復 8# 准提部林


  了解,十分感謝前輩指點,小弟會再努力練習.

TOP

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1447 
主題
40 
精華
0 
積分
1471 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2025-5-5 
10#
發表於 2023-5-11 14:12 | 只看該作者
回復 5# 准提部林


    謝謝論壇,謝謝前輩指導
後學藉此帖學習前輩的方案,方案學習心得註解如下,請前輩再指導

資料表:


結果表:



Sub TEST()
Dim Arr, D, T$, R&, C&
'↑宣告變數
Arr = Range("A2:F" & [A65536].End(3).Row)
'↑令Arr變數是二維陣列,以儲存格值帶入陣列裡
Set D = CreateObject("Scripting.Dictionary")
'↑令D變數是字典
For C = 1 To UBound(Arr, 2) Step 2
'↑設順迴圈跑欄!每繞回一次 +2 (1,3,5,.....)
    For R = 1 To UBound(Arr)
    '↑設順迴圈跑列!
        T = Arr(R, C): If T = "" Then GoTo 101
        '↑令T變數是迴圈的Arr陣列值
        '如果T變數是空字元!就跳到101標示位置繼續執行(空白不處理)
        If C = 1 Then D(T) = R: GoTo 101
        '↑如果C變數是1!就令以T變數當key,item是R變數(索引列號),
        '跳到101標示位置繼續執行
        Arr(R, C) = "": Arr(R, C + 1) = ""
        '↑令處理過的陣列位置清除
        '(因為用同一陣列放原資料調整為新資料)
        Arr(D(T), C) = T
        '↑令T變數查D字典得item值列第C變數欄Arr陣列值是 T變數
        Arr(D(T), C + 1) = Arr(D(T), 2)
        '↑令右側欄Arr陣列值是Arr陣列第2欄值
101: Next
Next
[期望結果示意!A3:F3].Resize(UBound(Arr)) = Arr
'↑令Arr陣列值寫入另一個工作表
End Sub
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

        靜思自在 : 盡多少本份，就得多少本事。
返回列表 上一主題