返回列表 上一主題 發帖

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

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

請問這一段如何改
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)

希望支持!

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

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

改成這樣可達成第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

謝謝二位大大幫忙,陣列與字典兩大利器,真的要花時間才有辦法吸收。
希望支持!

TOP

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

請問准大:
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?
希望支持!

TOP

准大:
指Ar = Array(    )與,Br = Array(),()內可否以變數代替,不要寫這麼長。
希望支持!

TOP

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

阿龍大:
經測試結果,仍達不到預期,如附檔。

使用数组和字典1071003.zip (12.75 KB)

希望支持!

TOP

阿龍大:
筆數30000筆,當了。
希望支持!

TOP

阿龍大:
快多了,0.34秒
希望支持!

TOP

        靜思自在 : 人的心地是一畦田,土地沒有播下好種子,也長不出好的果實。 -
返回列表 上一主題