iT邦幫忙

0

VBA 名單套印至表格求解

名單樣式(工作表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
怎麼不用word或publish來做套表列印?
0
rogeryao
iT邦大師 1 級 ‧ 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

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

0
blanksoul12
iT邦新手 4 級 ‧ 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

我要發表回答

立即登入回答