Board logo

標題: [發問] 如何自訂拷貝次數 [打印本頁]
作者: luke    時間: 2012-4-3 22:30     標題: 如何自訂拷貝次數

各位大大

小弟把常用資料作成資料列選單放在sheet2表資料區,
我想在sheet1表B1至B5去設定拷貝次數,然後複製貼上

煩請先進指導
[attach]10293[/attach]
作者: Hsieh    時間: 2012-4-3 22:56

回復 1# luke
  1. Sub nn()
  2. With sheet2
  3. Set Rng = .Range(.[A1], .[A1].End(xlDown))
  4. k = 11
  5. For Each a In sheet1.[B1:B5]
  6. mystr = "SUMPRODUCT((left(sheet2!" & Rng.Address & ",2)=""" & a.Offset(, -1) & """)*1)"
  7. Set c = .Columns("A:A").Find(a.Offset(, -1), after:=.[A65536], lookat:=xlPart)
  8. r = Evaluate(mystr)
  9. For i = 1 To a
  10.    c.Resize(r, 10).Copy sheet1.Cells(k, 1)
  11.    k = k + r
  12. Next
  13. Next
  14. End With
  15. End Sub
複製代碼
作者: register313    時間: 2012-4-3 23:08

回復 1# luke

附檔中,功能解說非常清楚,給你按一個讚
  1. Sub Macro()
  2. RX = 0
  3. sheet1.[A11:J65536].Clear
  4. For r = 1 To 5
  5.   N = 0
  6.   Do While N < sheet1.Cells(r, 2)
  7.    sheet2.Range("A" & r * 4 - 3).Resize(4, 10).Copy sheet1.[A11].Offset(RX, 0)
  8.    N = N + 1
  9.    RX = RX + 4
  10.   Loop
  11. Next r
  12. End Sub
複製代碼
作者: luke    時間: 2012-4-4 00:12

回復 3# register313

測試OK
非常謝謝  register313 和稱讚

PS: 我想將sheet2中AA-EE資料區實際列數作修改,如AA資料區3列,BB資料區5列,其他假設各為4列不變如附檔,
煩請大大指導

[attach]10294[/attach]
作者: luke    時間: 2012-4-4 00:15

回復 2# Hsieh


    測試OK   
    謝謝H版大
作者: register313    時間: 2012-4-4 09:37

回復 4# luke

Hsieh超版#2之程式即是:直接判斷SHEET2 A欄有幾個AA,幾個BB...,作為列數之判斷
若資料區之資料確為AA01 AA02 AA03...BB01 BB01 BB03....之規則
請使用Hsieh超版#2之程式即可

若資料區之資料無規則,則可使用下列程式,但SHEET1 D1~D5必須輸入
  1. Sub Macro()
  2. RX = 0
  3. Y = 1
  4. Sheet1.[A11:J65536].Clear
  5. For r = 1 To 5
  6.   N = 0
  7.   Do While N < Sheet1.Cells(r, 2)
  8.    Sheet2.Range("A" & Y).Resize(Cells(r, "D"), 10).Copy Sheet1.[A11].Offset(RX, 0)
  9.    N = N + 1
  10.    RX = RX + Cells(r, 4)
  11.   Loop
  12.   Y = Y + Cells(r, 4)
  13. Next r
  14. End Sub
複製代碼
作者: luke    時間: 2012-4-4 11:52

回復 6# register313
   
謝謝  register313, 程式測試OK

PS: Hsieh超版的#2程式SHEET2中 A欄有些問題,
1.若資料區無AA,BB...EE關鍵字會出現"沒有設定物件變數或With區塊變數"
2.若A欄中任一儲存格有"空白"儲存格會出現錯誤並顯示400
3.A欄若任一資料區所對應該區最後一列不是關鍵字, 該列將無法拷貝資料.

以上說明
作者: GBKEE    時間: 2012-4-4 12:35

回復 4# luke
  1. Option Explicit
  2. Sub Ex()
  3.     Dim E As Range, xf As Range, xi As Integer
  4.     With Sheet1
  5.         .[A11:J65536].Clear
  6.         For Each E In Sheet1.[a1:a5]
  7.             Set xf = Sheet2.[A:A].Find(E, lookat:=xlPart, After:=Sheet2.[A65536])
  8.             Set xf = xf.Resize(E.Cells(1, 4), 10)
  9.             For xi = 1 To E.Cells(1, 2)
  10.                 With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
  11.                     If .Row < 11 Then xf.Copy Sheet1.[a11] Else xf.Copy .Cells
  12.                 End With
  13.             Next
  14.         Next
  15.     End With
  16. End Sub
複製代碼
作者: Hsieh    時間: 2012-4-4 18:09

回復 7# luke
  1. Sub ex()
  2. Dim Ay()
  3. Set d = CreateObject("Scripting.Dictionary")
  4. With sheet2
  5.   For Each a In .Range(.[A1], .[A65536].End(xlUp))
  6.      If IsEmpty(d(Left(a, 2))) Then
  7.        Set d(Left(a, 2)) = a.Resize(, 10)
  8.        Else
  9.        Set d(Left(a, 2)) = Union(d(Left(a, 2)), a.Resize(, 10))
  10.     End If
  11. Next
  12. End With
  13. r = 11
  14. With sheet1
  15. .Range("A11").CurrentRegion.Clear
  16.   For Each a In .[B1:B5]
  17.   If d.exists(a.Offset(, -1).Value) = True Then
  18.       For i = 1 To a
  19.         d(a.Offset(, -1).Value).Copy .Cells(r, 1)
  20.         r = .Cells(11, 1).End(xlDown).Row + 1
  21.       Next
  22.   End If
  23.   Next
  24. End With
  25. End Sub
複製代碼
作者: luke    時間: 2012-4-4 20:58

回復 8# GBKEE

程式測試OK

小弟原本構思是從sheet2表去自訂5-10個資料區當作菜單, 每個資料區有10欄(A:J)以3-5列為乙區即每列10個儲存格*列數 (例如: AA資料區所代表AA01-AA30僅為該資料區所在代號位置), 也就是sheet2表A欄中有可能是空白, 文字公式來表示.

以下是測試(見第1點)說明:
1.假設sheet2表(檔案TEST5AA.rar), A欄BB資料區有5列,若把BB21和BB41即A6和A8同時改為空白, 拷貝過程中只會出現4列資料列, 無法拷貝5列資料列.

2.小弟轉述給register313中所提第3點“A欄若任一資料區所對應該區最後一列不是關鍵字, 該列將無法拷貝資料”是指H版大所給第1次程式有關鍵字限制,例如刪除如前項A8儲存格會造成無法拷貝該區(即sheet2表第8列)資料情形.

3.我想要的結果: 各資料區不管是何種格式不需去考慮關鍵字, 只需以sheet2表各資料區實際列數來拷貝即可.

謝謝GBKEE 版大
作者: luke    時間: 2012-4-4 20:58

回復 9# Hsieh


   
程式測試無錯誤
(說明見上)

謝謝H超版大



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