123
返回列表 上一主題 發帖

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

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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

字典1070913.zip (12.99 KB)

收藏 分享
希望支持!

Kubi

帖子
163 
主題
1 
精華
0 
積分
170 
點名
0  
作業系統
Window 7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2010-9-5 
最後登錄
2022-7-20 
2#
發表於 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
複製代碼

TOP

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
3#
發表於 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
希望支持!

TOP

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
4#
發表於 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
希望支持!

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
5#
發表於 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
複製代碼
使用数组和字典1070929.rar (13.22 KB)
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
6#
發表於 2018-9-29 03:40 | 只看該作者
本帖最後由 n7822123 於 2018-9-29 03:43 編輯

回復 5# n7822123

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

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

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

TOP

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-12-22 
7#
發表於 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

原題是要用[字典], 看看需求, 應該不用字典即可,
可能另有用意, 所以看了題就算了~~

TOP

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
8#
發表於 2018-10-1 08:24 | 只看該作者
謝謝二位大大幫忙，陣列與字典兩大利器，真的要花時間才有辦法吸收。
希望支持!

TOP

s7659109

帖子
248 
主題
76 
精華
0 
積分
331 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
性別
男 
來自
kaohsiung 
註冊時間
2013-6-10 
最後登錄
2020-7-3 
9#
發表於 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 的用法可否請准大解釋？
希望支持!

TOP

准提部林

帖子
2839 
主題
10 
精華
0 
積分
2895 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-12-22 
10#
發表於 2018-10-1 16:00 | 只看該作者
回復 9# s7659109


xA(2, Br(i))  等同  xA.CELLS(2, Br(i))

TOP

        靜思自在 : 多做多得。少做多失。
123
返回列表 上一主題