12
返回列表 上一主題 發帖

[發問] 如何自訂拷貝次數

luke

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

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2012-4-3 22:30 | 只看該作者

[發問] 如何自訂拷貝次數

各位大大

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

煩請先進指導
TEST5.rar (36.82 KB)
收藏 分享

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
41  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-2-16 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

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

2012龍年全勤獎章熱烈參與勳章
3#
發表於 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
複製代碼

TOP

luke

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

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
4#
發表於 2012-4-4 00:12 | 只看該作者
回復 3# register313

測試OK
非常謝謝  register313 和稱讚

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

TEST5AA.rar (43.35 KB)

TOP

luke

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

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
5#
發表於 2012-4-4 00:15 | 只看該作者
回復 2# Hsieh


    測試OK   
    謝謝H版大

TOP

register313
　頭銜: 麻辣 路人甲

大學生Rank: 4

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

2012龍年全勤獎章熱烈參與勳章
6#
發表於 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
複製代碼

TOP

luke

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

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
7#
發表於 2012-4-4 11:52 | 只看該作者
回復 6# register313
   
謝謝  register313, 程式測試OK

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

以上說明

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 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
複製代碼

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
41  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2025-2-16 

2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
9#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

luke

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

2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章
10#
發表於 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 版大

TOP

        靜思自在 : 受人點水之恩，須當湧泉以報。
12
返回列表 上一主題