luke

中學生 Rank: 2

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

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

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2012-8-18 11:26 | 只看該作者

[發問] 資列列自訂複製數量

各位大大

sheet1工作表A1:C10為資料區, 其中C欄為列複製數量, 於C欄輸入值後,
按下按鈕開始進行資料區複製,
若值為零時不做任何動作,
若值等於1時則複製該資料列1次,
若值大於1就依照所對應的值進行多次複製並對B欄(此為變數)按順序編號直到完成該值.

煩請先進大大指導

TEST24.rar (31.26 KB)

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2012-8-20 20:05 | 只看該作者

回復 5# luke

Option Explicit
Sub Ex()
Dim x As Integer, Rng As Range, i As Integer
x = 1
Set Rng = Cells(15, 1) '設於 [A15]
Do
For i = 1 To Cells(x, 3) '3:C欄
Rng = Cells(x, 1) '1:A欄'2:B欄
Rng.Offset(, 1) = Cells(x, 2) & IIf(Cells(x, 3) > 1, "-" & i, "")
Rng.Offset(, 2) = 1
Set Rng = Rng.Offset(4) '改這裡下移4列
Next
x = x + 1
Loop While Cells(x, 2) <> ""
End Sub

複製代碼

TOP

luke

中學生 Rank: 2

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

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

5^#

發表於 2012-8-20 18:21 | 只看該作者

回復 4# GBKEE

  謝謝版大

   僅B欄選定後的資料, 可否每隔3列再次複製至E欄
   如附檔所示E15, E19, E23和E27 儲存格

以上
煩請先進指導

TEST24-2.rar (25.46 KB)

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2012-8-18 20:23 | 只看該作者

回復 3# luke
3 改成 Loop While Cells(x, 2) <> ""

TOP

luke

中學生 Rank: 2

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

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

3^#

發表於 2012-8-18 17:47 | 只看該作者

回復 2# GBKEE

謝謝版大回覆

   若C欄中有空白格即C1:C10儲存格中, 任一儲存格有空白(非零值)時,
   資料列會被中斷複製命令
   例: C3="",下句要如何修改才會繼續未完的C5值如附檔所示
   Loop While Cells(x, 3) <> ""

以上煩請先進指導

TEST24-1.rar (16.51 KB)

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

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

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2012-8-18 13:39 | 只看該作者

回復 1# luke
試試看

Option Explicit
Sub Ex()
Dim x As Integer, Rng As Range, i As Integer
x = 1
Set Rng = Cells(15, 1) '設於 [A15]
Do
For i = 1 To Cells(x, 3) '3:C欄
Rng = Cells(x, 1) '1:A欄 '2:B欄
Rng.Offset(, 1) = Cells(x, 2) & IIf(Cells(x, 3) > 1, "-" & i, "")
Rng.Offset(, 2) = 1
Set Rng = Rng.Offset(1)
Next
x = x + 1
Loop While Cells(x, 3) <> ""
End Sub

複製代碼

TOP