12
返回列表 上一主題 發帖

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

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-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

lpk187

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

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

        靜思自在 : 有願放在心裡，沒有身體力行，正如耕田不播種，皆是空過因緣。
12
返回列表 上一主題