麻辣家族討論版版 » Excel程式區 » 如何從不同表進行不同列複製資料?

返回列表下一主題上一主題發帖

如何從不同表進行不同列複製資料?

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2012-5-8 14:55 | 只看該作者

如何從不同表進行不同列複製資料?

sheet1表每兩欄為資料區塊, 其首列均有相同代碼和列數如A,C,E,G,I,K,M,O,Q欄, 而次列如B,D,F,H,J,L,N,P,和R欄為資料內容, 各有4000資料列.

sheet3表A:D欄表示欲變更的資料內容, 其中A:B欄必須對sheet1表A:B與K:L做資料替換如sheet3表所對應的B1:B2儲存格內容為XX01和XX02要拷貝至sheet1表B1:B2儲存格和L1:L2儲存格, 往下餘此類推直到A:B欄無資料。同理, sheet3 表C:D欄也要對sheet1表做資料替換如sheet3表所對應的D1:D2儲存格內容為YY01和YY02要拷貝至sheet1表D1:D2儲存格,F1:F2儲存,H1:H2儲存,J1:J2儲存,N1:N2儲存,P1:P2儲存,R1:R2儲存,D1:D2儲存和L1:L2儲存格, 往下餘此類推直到C:D欄無資料如附檔結果說明.

如何從不同表進行不同列複製資料?

煩請先進大大指導

TEST18.rar (25.2 KB)

樓主熱帖

收藏

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

5^#

發表於 2012-5-9 18:40 | 只看該作者

回復 4# register313

謝謝R大

辛苦與付出

　頭銜: 麻辣路人甲

大學生 Rank: 4

帖子: 967
主題: 0
精華: 0
積分: 1001
點名: 0
作業系統: WIN XP
軟體版本: OFFICE 2003
閱讀權限: 50
性別: 男
來自: 台北
註冊時間: 2010-11-29
最後登錄: 2022-5-17

2012龍年全勤獎章熱烈參與勳章

4^#

發表於 2012-5-9 00:56 | 只看該作者

回復 3# luke

Sub xx()
Dim Rng1 As Range
Dim Rng2 As Range
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
With sheet3
For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
d1(R.Value) = R.Offset(0, 1).Value
d2(R.Value) = R.Offset(0, 3).Value
Next
End With
X = sheet3.[H1]
Ar = Switch(X = 1, Array(2), X = 2, Array(2), X = 3, Array(2), X = 4, Array(2), X = 5, Array(2, 12), X = 6, Array(2, 12), X = 7, Array(2, 12))
Br = Switch(X = 1, Array(4), X = 2, Array(4, 6), X = 3, Array(4, 6, 8), X = 4, Array(4, 6, 8, 10), X = 5, Array(4, 6, 8, 10), X = 6, Array(4, 6, 8, 10, 14), X = 7, Array(4, 6, 8, 10, 14, 16))
With sheet1
For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
If d1.exists(R.Value) Then
For I = 0 To UBound(Ar)
If Rng1 Is Nothing Then Set Rng1 = .Cells(R.Row, Ar(I)) Else Set Rng1 = Union(Rng1, .Cells(R.Row, Ar(I)))
Next I
Rng1.Value = d1(R.Value)
Set Rng1 = Nothing
For j = 0 To UBound(Br)
If Rng2 Is Nothing Then Set Rng2 = .Cells(R.Row, Br(j)) Else Set Rng2 = Union(Rng2, .Cells(R.Row, Br(j)))
Next j
Rng2.Value = d2(R.Value)
Set Rng2 = Nothing
End If
Next
End With
End Sub

複製代碼

中學生 Rank: 2

帖子: 140
主題: 37
精華: 0
積分: 193
點名: 0
作業系統: Windows XP
軟體版本: Office 2007
閱讀權限: 20
註冊時間: 2012-3-28
最後登錄: 2015-7-5

2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章

3^#

發表於 2012-5-8 23:51 | 只看該作者

回復 2# register313

謝謝H大

sheet3表H1儲存格是否可設定作為變數
當H1值=1時,僅複製sheet3表B欄資料至sheet1表的B欄和複製sheet3表D欄資料至sheet1表的D欄
當H1值=2時, 複製sheet3表B欄資料至sheet1表的B欄和複製sheet3表D欄資料至sheet1表的D欄和F欄
當H1值=3時, 複製sheet3表B欄資料至sheet1表的B欄和複製sheet3表D欄資料至sheet1表的D欄, F欄和H欄
當H1值=4時, 複製sheet3表B欄資料至sheet1表的B欄和複製sheet3表D欄資料至sheet1表的D欄, F欄, H欄和J欄
當H1值=5時, 複製sheet3表B欄資料至sheet1表的B欄和L欄, 並複製sheet3表D欄資料至sheet1表的D欄, F欄, H欄和J欄
當H1值=6時, 複製sheet3表B欄資料至sheet1表的B欄和L欄, 並複製sheet3表D欄資料至sheet1表的D欄, F欄, H欄, J欄和N欄
當H1值=7時, 複製sheet3表B欄資料至sheet1表的B欄和L欄, 複製sheet3表D欄資料至sheet1表的D欄, F欄, H欄 , J欄, N欄和P欄

如何修改程式

煩請先進大大指導

TEST18A.rar (15.69 KB)

　頭銜: 麻辣路人甲

大學生 Rank: 4

帖子: 967
主題: 0
精華: 0
積分: 1001
點名: 0
作業系統: WIN XP
軟體版本: OFFICE 2003
閱讀權限: 50
性別: 男
來自: 台北
註冊時間: 2010-11-29
最後登錄: 2022-5-17

2012龍年全勤獎章熱烈參與勳章

2^#

發表於 2012-5-8 18:46 | 只看該作者

回復 1# luke

Sub xx()
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
With Sheet3
For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
d1(R.Value) = R.Offset(0, 1).Value
d2(R.Value) = R.Offset(0, 3).Value
Next
End With
With Sheet1
For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
If d1.exists(R.Value) Then
Set Rng1 = Union(R.Offset(0, 1), R.Offset(0, 11))
Rng1.Value = d1(R.Value)
Set Rng2 = Union(R.Offset(0, 3), R.Offset(0, 5), R.Offset(0, 7), R.Offset(0, 9), R.Offset(0, 13), R.Offset(0, 15), R.Offset(0, 17))
Rng2.Value = d2(R.Value)
End If
Next
End With
End Sub

複製代碼

靜思自在 : 天上最美是星星，人生最美是溫情。

返回列表下一主題上一主題