返回列表 上一主題 發帖

原資料如何用字典拆分,入不連續的欄位

本帖最後由 n7822123 於 2018-9-29 03:29 編輯

回復 4# s7659109

我寫的比較長一些,但是更有"彈性",學號不連續也無所謂
  1. Sub test()
  2. Dim tt$, Rn&, Cn&, Ri&, Ci&
  3. Dim 資料範圍 As Range, 填寫範圍 As Range
  4. Set d = CreateObject("scripting.dictionary")
  5. Sheets("data").Activate
  6. Rn = Cells(Rows.Count, 1).End(xlUp).Row
  7. Cn = Cells(1, Columns.Count).End(xlToLeft).Column
  8. Set 資料範圍 = [b2].Resize(Rn - 1, Cn - 1)
  9. '輸入資料到字典
  10. For Each rg In 資料範圍
  11.   tt = Cells(1, rg.Column).Value
  12.   tt = tt & "," & Cells(rg.Row, 1).Value
  13.   d(tt) = rg.Value
  14. Next
  15. '==========我是分格線==========
  16. Sheets("test").Activate
  17. Ri = Cells(Rows.Count, 1).End(xlUp).Row
  18. Ci = Cells(1, Columns.Count).End(xlToLeft).Column
  19. Set 填寫範圍 = [b2].Resize(Ri - 1, Ci - 1)
  20. '從字典輸出資料
  21. For Each rg In 填寫範圍
  22.   tt = Cells(1, rg.Column).Value
  23.   tt = tt & "," & Cells(rg.Row, 1).Value
  24.   rg.Value = d(tt)
  25. Next
  26. End Sub
複製代碼
使用数组和字典1070929.rar (13.22 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2018-9-29 03:43 編輯

回復 5# n7822123

長歸長,但是應該很好理解
因為你的檔案是新版的".xlsm",
不然準大應該早就回你了,

這裡很多高手都還在用舊版excel,
下次要快點得到答案時,建議上傳的檔案用".xls"
以上是心得分享
:D

另存舊版excel 如下,這樣就有更多人加入討論!
使用数组和字典1070929.rar (8.73 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2018-10-2 22:33 編輯

回復 13# s7659109


   來源資料與要貼入的資料,需要建立1-1對應關係

   如果沒有規律的話,應該是沒辦法用變數取代的

  除非要寫判斷式找出2個工作表的對應關係,這樣就跟你的命題:不需判斷衝突了。
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2018-10-2 23:25 編輯

回復 14# n7822123


靈光一閃,這樣應該滿意了吧!?
程序:test2
  1. Sub test2()
  2. Set d = CreateObject("scripting.dictionary")
  3. Dim Rn&, Cn&, arr
  4. Sheets("data").Activate
  5. Rn = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
  6. Cn = Cells(1, Columns.Count).End(xlToLeft).Column
  7. For C = 2 To Cn: d(Cells(1, C).Value) = Cells(2, C).Resize(Rn - 1, 1): Next C
  8. Sheets("test").Activate: Cn = Cells(1, Columns.Count).End(xlToLeft).Column
  9. For C = 2 To Cn: Cells(2, C).Resize(Rn - 1, 1) = d(Cells(1, C).Value): Next C
  10. End Sub
複製代碼
使用数组和字典1071002+.rar (12.29 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2018-10-4 01:33 編輯

回復 16# s7659109


請使用你附件裡面的 "test2"程序!

test1 與 test2 都可以符合你的需求,不同寫法
test1 最彈性,學號也不連續也可以!

sheet2.test 程序是你自己原本的!
有點無言.....

按Alt+F8
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 n7822123 於 2018-10-4 11:25 編輯

回復 18# s7659109

應該不是當了,3萬筆要執行一段時間!
字典物件的key輸入字串型態可提升速度(這也是跟準大學習的)
test1 不需修改
程序 test2修改如下

Sub test2()
Set d = CreateObject("scripting.dictionary")
Dim Rn&, Cn&, arr, tt$
Sheets("data").Activate
Rn = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
Cn = Cells(1, Columns.Count).End(xlToLeft).Column
For C = 2 To Cn
  tt = Cells(1, C).Value
  d(tt) = Cells(2, C).Resize(Rn - 1, 1)
Next C
Sheets("test").Activate
Cn = Cells(1, Columns.Count).End(xlToLeft).Column
For C = 2 To Cn
  tt = Cells(1, C).Value
  Cells(2, C).Resize(Rn - 1, 1) = d(tt)
Next C
End Sub

使用数组和字典1071004.rar (8.64 KB)
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

        靜思自在 : 地上種了菜,就不易長草;心中有善,就不易生惡。
返回列表 上一主題