帖子: 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

中學生 Rank: 2

帖子: 163
主題: 1
精華: 0
積分: 170
點名: 0
作業系統: Window 7
軟體版本: Office 2007
閱讀權限: 20
性別: 男
註冊時間: 2010-9-5
最後登錄: 2022-7-20

2^#

發表於 2018-9-13 12:00 | 只看該作者

回復 1# s7659109
請參考

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, 7), arr(i, 8), "", arr(i, 4))
Next
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
End Sub

複製代碼

TOP

s7659109

中學生 Rank: 2

帖子: 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

中學生 Rank: 2

帖子: 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

我寫的比較長一些，但是更有"彈性"，學號不連續也無所謂

Sub test()
Dim tt$, Rn&, Cn&, Ri&, Ci&
Dim 資料範圍 As Range, 填寫範圍 As Range
Set d = CreateObject("scripting.dictionary")
Sheets("data").Activate
Rn = Cells(Rows.Count, 1).End(xlUp).Row
Cn = Cells(1, Columns.Count).End(xlToLeft).Column
Set 資料範圍 = [b2].Resize(Rn - 1, Cn - 1)
'輸入資料到字典
For Each rg In 資料範圍
tt = Cells(1, rg.Column).Value
tt = tt & "," & Cells(rg.Row, 1).Value
d(tt) = rg.Value
Next
'==========我是分格線==========
Sheets("test").Activate
Ri = Cells(Rows.Count, 1).End(xlUp).Row
Ci = Cells(1, Columns.Count).End(xlToLeft).Column
Set 填寫範圍 = [b2].Resize(Ri - 1, Ci - 1)
'從字典輸出資料
For Each rg In 填寫範圍
tt = Cells(1, rg.Column).Value
tt = tt & "," & Cells(rg.Row, 1).Value
rg.Value = d(tt)
Next
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

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-27

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