12
返回列表 上一主題 發帖

如何設定複製迴圈sheet1複製儲存格至sheet2固定位置????

poke0817
　暱稱: 嬌滴滴

中學生Rank: 2

帖子
9 
主題
1 
精華
0 
積分
50 
點名
0  
作業系統
windows 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-13 
最後登錄
2023-10-10 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2015-9-13 20:35 | 只看該作者

如何設定複製迴圈sheet1複製儲存格至sheet2固定位置????

本帖最後由 poke0817 於 2015-9-13 20:37 編輯



如圖一sheet1所示:A2及B2是所有需製做標籤的清單。
如圖二sheet2所示:已經製作好對應儲存格，A2(sheet1)需對應到B2(sheet2)，B2(sheet1)對應到B3(sheet2)。

1、如何設定迴圈將sheet1(A2/B2)清單依序的複製在sheet2(B2/B3)固定位置上?
2、sheet2標籤的格式以製作好了，若設定迴圈可以直接複製貼到相對位置，那如果我沒有把製作格式複製好，可以利用迴圈複製標籤隔式嗎?





財產標籤製作.rar (17.81 KB)
收藏 分享

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
2#
發表於 2015-9-13 22:36 | 只看該作者
回復 1# poke0817


  是這樣嗎？
我把標籤樣式改到Sheet3以應第2個問題
  1. Public Sub ex()
  2. Dim rng As Range, r%, c%
  3. Sheet3.Range("a1:h" & Sheet3.Cells(Rows.Count, 1).End(xlUp).Row).Delete
  4. r = 1
  5. c = 1
  6. For i = 1 To 8 Step 2
  7.     Sheet3.Columns(i).ColumnWidth = 9.65
  8.     Sheet3.Columns(i + 1).ColumnWidth = 18.13
  9. Next
  10. For Each rng In Sheet1.Range("a2:a" & Sheet1.Cells(Rows.Count, 1).End(xlUp).Row)
  11.     With Sheet3
  12.         If c < 8 Then
  13.             With .Range(.Cells(r, c), .Cells(r + 2, c + 1))
  14.                 .HorizontalAlignment = xlCenter
  15.                 .VerticalAlignment = xlCenter
  16.                 .WrapText = False
  17.                 .Orientation = 0
  18.                 .AddIndent = False
  19.                 .IndentLevel = 0
  20.                 .ShrinkToFit = True
  21.                 .ReadingOrder = xlContext
  22.                 .Borders(xlDiagonalDown).LineStyle = xlNone
  23.                 .Borders(xlDiagonalUp).LineStyle = xlNone
  24.                 With .Borders(xlEdgeLeft)
  25.                     .LineStyle = xlContinuous
  26.                     .ColorIndex = xlAutomatic
  27.                     .TintAndShade = 0
  28.                     .Weight = xlMedium
  29.                 End With
  30.                 With .Borders(xlEdgeTop)
  31.                     .LineStyle = xlContinuous
  32.                     .ColorIndex = xlAutomatic
  33.                     .TintAndShade = 0
  34.                     .Weight = xlMedium
  35.                 End With
  36.                 With .Borders(xlEdgeBottom)
  37.                     .LineStyle = xlContinuous
  38.                     .ColorIndex = xlAutomatic
  39.                     .TintAndShade = 0
  40.                     .Weight = xlMedium
  41.                 End With
  42.                 With .Borders(xlEdgeRight)
  43.                     .LineStyle = xlContinuous
  44.                     .ColorIndex = xlAutomatic
  45.                     .TintAndShade = 0
  46.                     .Weight = xlMedium
  47.                 End With
  48.                 With .Borders(xlInsideVertical)
  49.                     .LineStyle = xlContinuous
  50.                     .ColorIndex = xlAutomatic
  51.                     .TintAndShade = 0
  52.                     .Weight = xlThin
  53.                 End With
  54.                 With .Borders(xlInsideHorizontal)
  55.                     .LineStyle = xlContinuous
  56.                     .ColorIndex = xlAutomatic
  57.                     .TintAndShade = 0
  58.                     .Weight = xlThin
  59.                 End With
  60.                 With .Font
  61.                     .Name = "標楷體"
  62.                 End With
  63.             End With
  64.             With .Range(.Cells(r, c), .Cells(r, c + 1))
  65.                 .MergeCells = True
  66.                 .Value = "XX企業股份有限公司"
  67.                 With .Font
  68.                     .Size = 14
  69.                 End With
  70.             End With
  71.             .Cells(r + 1, c) = "財產編碼"
  72.             .Cells(r + 1, c + 1) = rng
  73.             .Cells(r + 2, c) = "品名"
  74.             .Cells(r + 2, c + 1) = rng.Offset(, 1)
  75.             c = c + 2
  76.         End If
  77.         If c > 8 Then
  78.             c = 1
  79.             r = r + 3
  80.         End If
  81.     End With
  82. Next
  83. End Sub
複製代碼

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
3#
發表於 2015-9-13 22:44 | 只看該作者
程式構想：
１．〔標籤清單〕工作表前３列，事先設定好表格樣式（只有標題文字，未填內容），
　　一排要幾欄（視列印大小），可由此決定，貼入資料時，即以此為樣本往右往下轉貼。
２．貼入資料時，從第４列開始，樣式就用前３列為來源，再逐一填入資料，
　　處理完成後，再刪去前３列。
３．執行〔清除〕，即可恢復原狀（爾後仍可重新更改樣式，程式只依樣複製）
  1. Sub 轉出()
  2. Dim R&, xR As Range, xH As Range, xE As Range
  3. Call 清除
  4. R = [標籤清單!A65536].End(xlUp).Row
  5. If R < 2 Then Exit Sub
  6. Set xH = [標籤樣式!A4]: Set xE = xH

  8. For Each xR In [標籤清單!A2].Resize(R - 1)
  9.     If xH = "" Then [標籤樣式!1:3].Copy xE
  10.     xE(2, 2) = xR
  11.     xE(3, 2) = xR(1, 2)
  12.     Set xE = xE(1, 3)
  13.     If xE = "" Then Set xH = xH(4): Set xE = xH
  14. Next
  15. [標籤樣式!1:3].EntireRow.Delete
  16. Application.Goto [標籤樣式!A1]
  17. End Sub
複製代碼
　
附件下載：
財產標籤製作v01.rar (16.22 KB) 　
　

TOP

poke0817
　暱稱: 嬌滴滴

中學生Rank: 2

帖子
9 
主題
1 
精華
0 
積分
50 
點名
0  
作業系統
windows 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-13 
最後登錄
2023-10-10 
4#
發表於 2015-9-14 19:56 | 只看該作者
回復 2# lpk187


大大果然厲害，但很好奇，我在公司測試的時候公司是2003版本，卻一直出錯誤，因不了解各項次的設定所以沒在嘗試修改，回到家在測試一次，居然可以!!!!!!
這是有限版本嗎???

TOP

poke0817
　暱稱: 嬌滴滴

中學生Rank: 2

帖子
9 
主題
1 
精華
0 
積分
50 
點名
0  
作業系統
windows 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-13 
最後登錄
2023-10-10 
5#
發表於 2015-9-14 20:12 | 只看該作者
回復 3# 准提部林

    版大，今天有測試您寫的，一開始出現錯誤，將Call 清除(這出現錯誤，刪除後就可以執行了)，感謝啦!
但有個問題，我有嘗試將一個標籤用兩個財產編號，但修改後仍是一個一個跳如下:

Sub 轉出()
Dim R&, xR As Range, xH As Range, xE As Range
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(1)
    xE(3, 2) = xR(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

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2015-9-14 20:13 | 只看該作者
回復  lpk187


大大果然厲害，但很好奇，我在公司測試的時候公司是2003版本，卻一直出錯誤，因不了解 ...
poke0817 發表於 2015/9/14 19:56


我也是2003版本,准提部林版主的附檔可正常執行程式.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

poke0817
　暱稱: 嬌滴滴

中學生Rank: 2

帖子
9 
主題
1 
精華
0 
積分
50 
點名
0  
作業系統
windows 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-13 
最後登錄
2023-10-10 
7#
發表於 2015-9-14 20:31 | 只看該作者
回復 1# poke0817


   想請問，如果有一個清單，可是須對應三種標籤，
1、依項次1(清單)，A~D的欄位for 標籤樣式1(對應該清單的料號、品名、批號、盒數)，在依照清單(C7開始)高度排列(C7、C8、C9、C10)，直到C欄清單結束。
2、依項次1(清單)，F~I的欄位for 標籤樣式2(對應該清單的料號、品名、批號、盒數)，在依照清單(H7開始)高度排列(B5、D5)，直到C欄清單結束。(標籤3的方式應該跟此一樣，只是對應的清單區域不一樣)

標籤快把我搞死了，研究不出所以然來.......之前錄製巨集到眼花，又被主管打槍=  =!!
標籤製作.rar (20.99 KB)

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-25 
8#
發表於 2015-9-14 20:32 | 只看該作者
回復 5# poke0817


不可使用是因為您〔沒有下載〕附檔，詳細看裡面還有一個 sub 清除() 程式，
〔清除〕程式我一般會另外寫！

表格〔第一排〕請依您的所需先右貼，要貼幾個模板依〔列印寬度〕而定，而不是只有Ａ１：Ｂ３一組，
這個做法可減少很多程式碼，反正第一排怎設定，程式依樣畫葫蘆，
若有更改也不須去更動大部份的程式，只要直接對表格修改即可！

xR(1) → xR.cells(1,1)
xR(2) → xR.cells(2,1) 是它的〔下一格〕，若要指定其〔右一格〕，則為 xR(1,2) →　等同于 xR.cells(1,2)

TOP

poke0817
　暱稱: 嬌滴滴

中學生Rank: 2

帖子
9 
主題
1 
精華
0 
積分
50 
點名
0  
作業系統
windows 
軟體版本
Office 2003 
閱讀權限
20 
性別
男 
註冊時間
2015-9-13 
最後登錄
2023-10-10 
9#
發表於 2015-9-14 21:34 | 只看該作者
回復 8# 准提部林


    准提部林 :感謝版大，因附件有限層級，小弟我還太嫩，所以沒辦法下載來看，有在針對你撰寫的程式去測試，依照一張標籤作對應清單四組修改，但在跑迴圈時還是會依照清單第二組開始重新續編，無法依照清單第五組開始，如圖所示....如果可以續編我其它三個標籤方式應該可以跟著修正，差在盒數的部分就沒辦法接續+1了。

TOP

lpk187

帖子
552 
主題
3 
精華
0 
積分
578 
點名
0  
作業系統
win7 
軟體版本
office 2010 
閱讀權限
50 
性別
男 
註冊時間
2015-2-8 
最後登錄
2024-7-9 

2016猴年全勤獎章2015羊年全勤獎章熱烈參與勳章
10#
發表於 2015-9-15 09:59 | 只看該作者
回復 4# poke0817


    製作儲存格格式，和版本有關係！2003不相容！

TOP

        靜思自在 : 話多不如話少，話少不如話好。
12
返回列表 上一主題