Board logo

標題: 如何從不同表進行不同列複製資料? [打印本頁]
作者: luke    時間: 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欄無資料如附檔結果說明.

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

煩請先進 大大指導
[attach]10856[/attach]
作者: register313    時間: 2012-5-8 18:46

回復 1# luke
  1. Sub xx()
  2. Set d1 = CreateObject("Scripting.Dictionary")
  3. Set d2 = CreateObject("Scripting.Dictionary")
  4. With Sheet3
  5.   For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
  6.     d1(R.Value) = R.Offset(0, 1).Value
  7.     d2(R.Value) = R.Offset(0, 3).Value
  8.   Next
  9. End With
  10. With Sheet1
  11.   For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
  12.     If d1.exists(R.Value) Then
  13.       Set Rng1 = Union(R.Offset(0, 1), R.Offset(0, 11))
  14.       Rng1.Value = d1(R.Value)
  15.       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))
  16.       Rng2.Value = d2(R.Value)
  17.     End If
  18.   Next
  19. End With
  20. End Sub
複製代碼
作者: luke    時間: 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欄

如何修改程式

煩請先進 大大指導
[attach]10870[/attach]
作者: register313    時間: 2012-5-9 00:56

回復 3# luke
  1. Sub xx()
  2. Dim Rng1 As Range
  3. Dim Rng2 As Range
  4. Set d1 = CreateObject("Scripting.Dictionary")
  5. Set d2 = CreateObject("Scripting.Dictionary")
  6. With sheet3
  7.   For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
  8.     d1(R.Value) = R.Offset(0, 1).Value
  9.     d2(R.Value) = R.Offset(0, 3).Value
  10.   Next
  11. End With
  12. X = sheet3.[H1]
  13. 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))
  14. 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))
  15. With sheet1
  16.   For Each R In .Range("A1:A" & .[A1].End(xlDown).Row)
  17.     If d1.exists(R.Value) Then
  18.       For I = 0 To UBound(Ar)
  19.         If Rng1 Is Nothing Then Set Rng1 = .Cells(R.Row, Ar(I)) Else Set Rng1 = Union(Rng1, .Cells(R.Row, Ar(I)))
  20.       Next I
  21.       Rng1.Value = d1(R.Value)
  22.       Set Rng1 = Nothing
  23.       For j = 0 To UBound(Br)
  24.         If Rng2 Is Nothing Then Set Rng2 = .Cells(R.Row, Br(j)) Else Set Rng2 = Union(Rng2, .Cells(R.Row, Br(j)))
  25.       Next j
  26.       Rng2.Value = d2(R.Value)
  27.       Set Rng2 = Nothing
  28.     End If
  29.   Next
  30. End With
  31. End Sub
複製代碼
作者: luke    時間: 2012-5-9 18:40

回復 4# register313


    謝謝R大

   辛苦與付出



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