iT邦幫忙

0

VBA 名單套印至表格求解

excel vba vba #excel #vba excelvba
peterzxcv 2021-06-13 14:37:44 ‧ 2099 瀏覽

  • 分享至 

  • xImage

名單樣式(工作表1)
https://ithelp.ithome.com.tw/upload/images/20210613/20120368EK43AaaOyX.jpg
表格樣式(工作表2)
https://ithelp.ithome.com.tw/upload/images/20210613/20120368TBeOIUVgUy.jpg
欲套印結果跨儲存格說明
https://ithelp.ithome.com.tw/upload/images/20210613/20120368HDX6uiPDW4.jpg
欲套印結果(工作表3)
https://ithelp.ithome.com.tw/upload/images/20210613/20120368DSg2UQlbqx.jpg

檔案樣式
https://www.mediafire.com/file/o6igk8t2z65znot/TEST.xlsx/file
請求各位專家幫忙，謝謝

peterzxcv iT邦新手 5 級 ‧ 2021-06-13 21:19:15 檢舉
個人的構想如下，只導入名單語法，目前實際執行是無作用，小弟很多語法還不是很清楚，代數的部分看看是否有甚麼語法方式改寫，或許就有作用，因為之前很多發問都整合在EXCEL中使用，只是希望WORD的套印部分也能整合進來，畢竟很制式不會有變化，完成一次就受用無窮，若能在IT邦幫忙網內有VBA語法樣板，也可幫些與我相同的人多個選擇。

Sub TRY()

lastrow = Worksheets("工作表1").Cells(Rows.Count, 1).End(xlUp).Row '算總數
Worksheets("工作表1").Range("F1") = Application.WorksheetFunction.CountIf(Range("工作表1!A1:A" & lastrow), "<>" & "")

F1 = Worksheets("工作表1").Range("F1")

'9宮格方式推算代數，每三格往下移4列，每九格往下移39列，其他有規則湊位移
X = i \ 3
Y = i \ 9

'A-G欄表格代數
A1 = i + 4 + 4 * X + 39 * Y
A2 = i + 5 + 4 * X + 39 * Y
A3 = i + 5 + 4 * X + 39 * Y
A4 = i + 6 + 4 * X + 39 * Y

'H-N欄表格代數
B1 = i + 3 + 4 * X + 39 * Y
B2 = i + 4 + 4 * X + 39 * Y
B3 = i + 4 + 4 * X + 39 * Y
B4 = i + 5 + 4 * X + 39 * Y

'H-N欄表格代數
C1 = i - 2 + 4 * X + 39 * Y
C2 = i - 1 + 4 * X + 39 * Y
C3 = i - 1 + 4 * X + 39 * Y
C4 = i + 0 + 4 * X + 39 * Y

' 批量套入工作表3
For i = 1 To F1 Step 3 '1,4,7....
Worksheets("工作表1").Range("A" & i).Copy Destination:=Worksheets("工作表3").Range("C" & "A1")
Worksheets("工作表1").Range("B" & i).Copy Destination:=Worksheets("工作表3").Range("B" & "A2")
Worksheets("工作表1").Range("C" & i).Copy Destination:=Worksheets("工作表3").Range("F" & "A3")
Worksheets("工作表1").Range("D" & i).Copy Destination:=Worksheets("工作表3").Range("C" & "A4")
Next i

For i = 2 To F1 Step 3 '2,5,8....
Worksheets("工作表1").Range("A" & i).Copy Destination:=Worksheets("工作表3").Range("J" & "B1")
Worksheets("工作表1").Range("B" & i).Copy Destination:=Worksheets("工作表3").Range("I" & "B2")
Worksheets("工作表1").Range("C" & i).Copy Destination:=Worksheets("工作表3").Range("M" & "B3")
Worksheets("工作表1").Range("B" & i).Copy Destination:=Worksheets("工作表3").Range("J" & "B4")
Next i

For i = 3 To F1 Step 3 '3,6,9....
Worksheets("工作表1").Range("A" & i).Copy Destination:=Worksheets("工作表3").Range("Q" & "C1")
Worksheets("工作表1").Range("B" & i).Copy Destination:=Worksheets("工作表3").Range("P" & "C2")
Worksheets("工作表1").Range("C" & i).Copy Destination:=Worksheets("工作表3").Range("T" & "C3")
Worksheets("工作表1").Range("B" & i).Copy Destination:=Worksheets("工作表3").Range("Q" & "C4")
Next i

End Sub
japhenchen iT邦超人 1 級 ‧ 2021-06-15 07:57:39 檢舉
怎麼不用word或publish來做套表列印？
登入發表討論
圖片
  直播研討會
圖片
{{ item.channelVendor }} {{ item.webinarstarted }} |
{{ formatDate(item.duration) }}
直播中

3 個回答

0
rogeryao
iT邦超人 8 級 ‧ 2021-06-14 12:56:26
最佳解答 
Private Sub CommandButton1_Click()
Dim K As Integer
Dim M As Integer
Dim BlockX As Integer
Dim BlockY As Integer
Dim TempY As Integer
Dim APosX As Integer
Dim APosY As Integer
Dim BPosX As Integer
Dim BPosY As Integer
Dim CPosX As Integer
Dim CPosY As Integer
Dim DPosX As Integer
Dim DPosY As Integer
Dim TotalRow As Integer
Dim M_Max As Integer
TotalRow = Worksheets("工作表1").Range("A65536").End(xlUp).Row
' 計算由【工作表1】的資料每次抓 9 筆的次數
M_Max = Application.Ceiling(TotalRow / 9, 1)

For M = 1 To M_Max
  ' 計算【工作表2】九宮格相對位置
  For K = 1 To 9
    BlockY = Application.Ceiling(K / 3, 1)
    TempY = K Mod 3
    If TempY = 0 Then
      BlockX = 3
    Else
      BlockX = TempY
    End If
    
    ' 計算【工作表2】的填寫位置
    If BlockY = 1 Then
      APosY = 5
    ElseIf BlockY = 2 Then
      APosY = 12
    Else
      APosY = 19
    End If
    
    BPosY = APosY + 1
    CPosY = APosY + 1
    DPosY = APosY + 2
    
    If BlockX = 1 Then
      APosX = 3
    ElseIf BlockX = 2 Then
      APosX = 10
    Else
      APosX = 17
    End If
    
    BPosX = APosX - 1
    CPosX = APosX + 3
    DPosX = APosX
    
    '將【工作表1】資料寫入【工作表2】
    ' 欄位 A
    Sheets("工作表2").Cells(APosY, APosX) = Sheets("工作表1").Cells(9 * (M - 1) + K, 1)
    ' 欄位 B
    Sheets("工作表2").Cells(BPosY, BPosX) = Sheets("工作表1").Cells(9 * (M - 1) + K, 2)
    ' 欄位 C
    Sheets("工作表2").Cells(CPosY, CPosX) = Sheets("工作表1").Cells(9 * (M - 1) + K, 3)
    ' 欄位 D
    Sheets("工作表2").Cells(DPosY, DPosX) = Sheets("工作表1").Cells(9 * (M - 1) + K, 4)
  Next K
  '將【工作表2】複製到【工作表3】
  Sheets("工作表2").Select
  Sheets("工作表2").Range("A1:U53").Select
  Selection.Copy
  Sheets("工作表3").Select
  Sheets("工作表3").Range("A" & (M - 1) * 53 + 1).Select
  Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
  Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
      False, Transpose:=False
Next M
End Sub
peterzxcv iT邦新手 5 級 ‧ 2021-06-14 16:57:54 檢舉

原來要用區塊迴圈內放入位移，感謝rogeryao大神，若用Function能否將我原先代數一串解決呢，剛執行再一次執行，頭尾要加上開關比較方便
Application.DisplayAlerts = False
Application.DisplayAlerts = True
另一個很奇怪的是列印跟WORD套印一樣問題，就是會多出很多空白頁，多餘儲存格沒動用到也不是空格卻都會顯示再列印中，這是哪個環結問題

登入發表回應
0
IT 癡
iT邦高手 1 級 ‧ 2021-06-13 16:19:54

"名單樣式(工作表1)"
你為何不用 word 的套印功能更好處理你的需求，word 裡設定好表格格式後不會異動，但 excel 會隨著你資料寬度可能變動
https://www.google.com/search?q=word+%E5%A6%82%E4%BD%95%E5%A5%97%E5%8D%B0&oq=word+%E7%9A%84%E5%A5%97%E5%8D%B0%E5%8A%9F%E8%83%BD&aqs=chrome.1.69i57j0i333l2.3624j0j7&sourceid=chrome&ie=UTF-8

IT 癡 iT邦高手 1 級 ‧ 2021-06-13 16:22:05 檢舉

Office 各軟體有其專長功能與功用，資料處理 (包含簡單式資料庫) 是 excel 專業，但像你要的表格或套印是 word 的專長，你應各取所長做最有效的使用，建議啦

登入發表回應
0
blanksoul12
iT邦研究生 5 級 ‧ 2021-06-15 09:22:31

這不可用"="解決嗎?

peterzxcv iT邦新手 5 級 ‧ 2021-06-16 00:05:22 檢舉

我有試過，複製許多工作表3空表用"="去勾稽工作表1，但工作表1清除換新的資料進去，工作表3"="會失效
https://ithelp.ithome.com.tw/upload/images/20210616/20120368HqOsH4msYq.jpg

登入發表回應

我要發表回答

立即登入回答
iThome鐵人賽
參賽組數
1123 組
團體組數
52 組
累計文章數
23096 篇
完賽人數
656 人
iT+看影片追技術 看影片追技術 看更多
熱門tag 看更多
15th鐵人賽 13th鐵人賽 14th鐵人賽 12th鐵人賽 11th鐵人賽 鐵人賽 2019鐵人賽 2018鐵人賽 javascript 2017鐵人賽 python windows php c# windows server linux css 程式設計 react vue.js
熱門問題
熱門回答
熱門文章
IT邦幫忙