Board logo

標題: 原資料如何用字典拆分，入不連續的欄位 [打印本頁]
作者: s7659109    時間: 2018-9-13 11:20     標題: 原資料如何用字典拆分，入不連續的欄位

請問這一段如何改
Sub test() '字典與數組
Dim arr
    Set d = CreateObject("scripting.dictionary")
    Dim lastrow&
    lastrow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
    arr = Sheet3.Range("a1:h" & lastrow)
    For i = 2 To UBound(arr)
'        d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6), arr(i, 7), arr(i, 8))
        d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 6), arr(i, 7), arr(i, 8))
    Next
    For Each Rng In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
        Rng.Offset(0, 1).Resize(1, 8) = d(Rng.Value)
    Next
End Sub
作者: Kubi    時間: 2018-9-13 12:00

回復 1# s7659109
請參考
  1. Sub test() '字典與數組
  2.     Dim arr
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Dim lastrow&
  5.     lastrow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
  6.     arr = Sheet3.Range("a1:h" & lastrow)
  7.     For i = 2 To UBound(arr)
  8. '        d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6), arr(i, 7), arr(i, 8))
  9.         d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), "", arr(i, 7), arr(i, 8), "", arr(i, 4))
  10.     Next
  11.     For Each Rng In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
  12.         Rng.Offset(0, 1).Resize(1, 7) = d(Rng.Value)
  13.     Next
  14. End Sub
複製代碼
作者: s7659109    時間: 2018-9-13 12:26

如果 只是要欄位匯入，不判斷，下面要如何改？

For Each Rng In Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
        Rng.Offset(0, 1).Resize(1, 7) = d(Rng.Value)
    Next
作者: s7659109    時間: 2018-9-14 14:42

改成這樣可達成第2問題，但有更好的嗎？
Sub test()
Dim arr1, arr2, r, rr
    With Sheets("sheet1")
            r = .Cells(.Rows.Count, 1).End(3).Row
            arr1 = .Range("a1:H" & r)
            arr2 = .Range("i1:q" & r)
    End With
            rr = Cells(Rows.Count, 1).End(3).Row
            Range("A2:h" & rr).ClearContents
            Range("R2:Z" & rr).ClearContents
            [A1].Resize(r, 8) = arr1
            [r1].Resize(r, 9) = arr2
End Sub
作者: n7822123    時間: 2018-9-29 03:17

本帖最後由 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
複製代碼
[attach]29462[/attach]
作者: n7822123    時間: 2018-9-29 03:40

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

回復 5# n7822123

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

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

另存舊版excel 如下，這樣就有更多人加入討論!
[attach]29463[/attach]
作者: 准提部林    時間: 2018-9-29 09:39

本帖最後由 准提部林 於 2018-9-29 09:44 編輯

Sub test2()
Dim R&, Ar, Br, xA As Range
Set xA = [data!a1]
R = xA(Rows.Count, 1).End(xlUp).Row - 1
Ar = Array(2, 3, 5, 6, 8) '來源資料要複製的[欄位]順序
Br = Array(2, 3, 7, 8, 4) '要貼入的[欄位]順序
For i = 0 To UBound(Ar)
    Cells(2, Ar(i)).Resize(R) = xA(2, Br(i)).Resize(R).Value
Next i
End Sub

原題是要用[字典], 看看需求, 應該不用字典即可,
可能另有用意, 所以看了題就算了~~
作者: s7659109    時間: 2018-10-1 08:24

謝謝二位大大幫忙，陣列與字典兩大利器，真的要花時間才有辦法吸收。
作者: s7659109    時間: 2018-10-1 11:56

Set xA = [data!a1]
For i = 0 To UBound(Ar)
    Cells(2, Ar(i)).Resize(R) = xA(2, Br(i)).Resize(R).Value
Next i
XA 的用法可否請准大解釋？
作者: 准提部林    時間: 2018-10-1 16:00

回復 9# s7659109


xA(2, Br(i))  等同  xA.CELLS(2, Br(i))
作者: s7659109    時間: 2018-10-2 10:43

請問准大：
Ar = Array(1, 2, 3, 4, 5, 6, 7, 8, 18, 19, 20, 21, 22, 23, 24, 25, 26) '來源資料要複製的[欄位]順序
Br = Array(1, 2, 3, 4, 5, 6, 7, 8, 11, 12, 13, 14, 15, 16, 17, 18, 19) '要貼入的[欄位]順序
如果貼入順序改成這樣，如何改for next?
作者: 准提部林    時間: 2018-10-2 12:16

回復 11# s7659109


一樣是
For i = 0 To UBound(Ar)
作者: s7659109    時間: 2018-10-2 12:42

准大：
指Ar = Array(    ）與，Br = Array(），（）內可否以變數代替，不要寫這麼長。
作者: n7822123    時間: 2018-10-2 22:22

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

回復 13# s7659109


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

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

  除非要寫判斷式找出2個工作表的對應關係，這樣就跟你的命題:不需判斷衝突了。
作者: n7822123    時間: 2018-10-2 23:10

本帖最後由 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
複製代碼
[attach]29485[/attach]
作者: s7659109    時間: 2018-10-3 08:26

本帖最後由 s7659109 於 2018-10-3 08:27 編輯

阿龍大：
經測試結果，仍達不到預期，如附檔。
作者: n7822123    時間: 2018-10-4 01:18

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

回復 16# s7659109


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

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

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

按Alt+F8
[attach]29495[/attach]
作者: s7659109    時間: 2018-10-4 08:33

阿龍大：
筆數30000筆，當了。
作者: 准提部林    時間: 2018-10-4 11:13

回復 13# s7659109

Ar = Array(1, 2, 3, 4, 5, 6, 7, 8, 18, 19, 20, 21, 22, 23, 24, 25, 26)
Br = Array(1, 2, 3, 4, 5, 6, 7, 8, 11, 12, 13, 14, 15, 16, 17, 18, 19)

如果是像上面這樣[兩段式]的連續欄位:
Cells(2, 1).Resize(R, 8) = xA(2, 1).Resize(R, 8).Value
Cells(2, 18).Resize(R, 9) = xA(2, 11).Resize(R, 9).Value
作者: n7822123    時間: 2018-10-4 11:23

本帖最後由 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

[attach]29498[/attach]
作者: s7659109    時間: 2018-10-4 11:53

阿龍大：
快多了，0.34秒
作者: GBKEE    時間: 2018-10-5 15:49

回復 21# s7659109

不用字典物件
  1. Option Explicit
  2. Sub Ex()
  3.     Dim Rng As Range, S As Variant, Ar(), Arr(), i As Long, ii As Integer
  4.     With Sheets("test")
  5.         Set Rng = .Range("b1:" & .Cells(1, Columns.Count).End(xlToLeft).Address) 'test上的欄位
  6.         Ar = Application.Transpose(Application.Transpose(Rng))
  7.         For i = 1 To Rng.Cells.Count
  8.             S = Application.Match(Rng(i), Sheets("data").Rows(1), 0)
  9.             Ar(i) = IIf(IsError(S), "", S)  '置入test上的欄位在data上的欄號
  10.         Next
  11.         Set Rng = .Range("a2:" & .Cells(Rows.Count, 1).End(xlUp).Address).Resize(, Rng.Columns.Count + 1)
  12.         Arr = Rng
  13.     End With
  14.     For i = 1 To UBound(Arr)
  15.         S = Application.Match(Arr(i, 1), Sheets("data").Columns(1), 0)
  16.         If Not IsError(S) Then    'test上的學號在data上的位置
  17.             For ii = 1 To UBound(Ar) '導入test上的欄位在data上的欄號
  18.              If Ar(ii) <> "" Then Arr(i, ii + 1) = Sheets("data").Cells(S, Ar(ii))
  19.             Next
  20.         End If
  21.     Next
  22.     Rng.Value = Arr
  23. End Sub
複製代碼




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