如何設定複製迴圈sheet1複製儲存格至sheet2固定位置????
- 帖子
- 2848
- 主題
- 10
- 精華
- 0
- 積分
- 2903
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2026-7-25
|
程式構想：
１．〔標籤清單〕工作表前３列，事先設定好表格樣式（只有標題文字，未填內容），
一排要幾欄（視列印大小），可由此決定，貼入資料時，即以此為樣本往右往下轉貼。
２．貼入資料時，從第４列開始，樣式就用前３列為來源，再逐一填入資料，
處理完成後，再刪去前３列。
３．執行〔清除〕，即可恢復原狀（爾後仍可重新更改樣式，程式只依樣複製）- Sub 轉出()
- Dim R&, xR As Range, xH As Range, xE As Range
- Call 清除
- R = [標籤清單!A65536].End(xlUp).Row
- If R < 2 Then Exit Sub
- Set xH = [標籤樣式!A4]: Set xE = xH
-
- For Each xR In [標籤清單!A2].Resize(R - 1)
- If xH = "" Then [標籤樣式!1:3].Copy xE
- xE(2, 2) = xR
- xE(3, 2) = xR(1, 2)
- Set xE = xE(1, 3)
- If xE = "" Then Set xH = xH(4): Set xE = xH
- Next
- [標籤樣式!1:3].EntireRow.Delete
- Application.Goto [標籤樣式!A1]
- End Sub
附件下載：
 財產標籤製作v01.rar (16.22 KB)
|
|
|
|
|
|
|
|
- 帖子
- 2848
- 主題
- 10
- 精華
- 0
- 積分
- 2903
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2026-7-25
|
回復 5# poke0817
不可使用是因為您〔沒有下載〕附檔，詳細看裡面還有一個 sub 清除() 程式，
〔清除〕程式我一般會另外寫！
表格〔第一排〕請依您的所需先右貼，要貼幾個模板依〔列印寬度〕而定，而不是只有Ａ１：Ｂ３一組，
這個做法可減少很多程式碼，反正第一排怎設定，程式依樣畫葫蘆，
若有更改也不須去更動大部份的程式，只要直接對表格修改即可！
xR(1) → xR.cells(1,1)
xR(2) → xR.cells(2,1) 是它的〔下一格〕，若要指定其〔右一格〕，則為 xR(1,2) → 等同于 xR.cells(1,2) |
|
|
|
|
|
|
|
- 帖子
- 2848
- 主題
- 10
- 精華
- 0
- 積分
- 2903
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2026-7-25
|
回復 9# poke0817
１．每次遇到問題內容演變到最後上傳的附件都不一樣，修修改改，很頭痛！
只能做到這個附檔為止，若有差異請自行修改！
２．請務必下載範例檔詳細看（已設定標籤的列印樣式，幾乎是客製化了∼∼），
以新入會員無法下載附檔，再破例多提供另一下載址，請儘量參與論壇交流，以提升下載權限！
３．標籤樣式有兩種，所以程式碼分別設置，比對兩種應可更了解程式的意思！- Sub 轉入1()
- Dim xA As Range, xB As Range, xR As Range, xH As Range, xE As Range
- Call 清除1
- Set xA = [清單!C2]: Set xB = [清單!B7]
- If xB = "" Then Exit Sub
-
- Set xH = [A10]: Set xE = xH '定位資料輸出儲存格位置
- Application.ScreenUpdating = False
-
- Do: If xH = "" Then Rows("1:8").Copy xH(0, 1) '複製空白樣式
- xE(2, 1) = xA(1, 1) '填入〔料號〕
- xE(3, 2) = xA(1, 1) '填入〔料號〕
- xE(4, 2) = xA(2, 1) '填入〔品名〕
- xE(4, 4) = xA(4, 1) '填入〔批號〕
- xE(5, 2) = xB(1, 2) '填入〔高度1〕
- xE(6, 2) = xB(2, 2) '填入〔高度2〕
- xE(5, 4) = xB(3, 2) '填入〔高度3〕
- xE(6, 4) = xB(4, 2) '填入〔高度4〕
- xE(7, 2) = xB(1, 1) '填入〔盒數〕
- xE(7, 4) = xB(1, 3) '填入〔備註〕
- Set xE = xE(1, 6) '定位下一筆填入位置
- If xE = "" Then Set xH = xH(9): Set xE = xH '若右方已無可填入表格，向下定位
- Set xB = xB(5, 1) '下一筆資料來源位置
- Loop Until xB = ""
-
- Rows("1:8").Delete
- End Sub
-
- '＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
- Sub 清除1()
- With ActiveSheet
- .UsedRange.Offset(8, 0).EntireRow.Delete '清除第８列以下資料
- .[A3,B4,B5:B8,D5:D8] = ""
- .[A2:E8].Copy [F2:o8]
- End With
- End Sub
附件下載：
標籤製作v01.rar (32.79 KB)
或
http://www.funp.net/783355 |
|
|
|
|
|
|
|
發表於 2015-9-13 22:44
| 
