標題: VBA求救高手，將資料按頁次順序排列 [打印本頁]

---

作者: wsx1130    時間: 2023-1-17 19:29     標題: VBA求救高手，將資料按頁次順序排列

將資料轉到A~F欄
一頁為120個項目
第一頁
A=1~40
C=41~80
E=81~120
第二頁
A=121~160
C=161~200
E=201~240
....到最後

[attach]35752[/attach]

---

作者: 准提部林    時間: 2023-1-17 21:01

Sub TEST_A1()
Dim xA As Range, xR As Range
Intersect(ActiveSheet.UsedRange, Range("a:f")).Offset(2, 0).Clear
Application.ScreenUpdating = False
Set xA = [a3]:  Set xR = [k2]
Do While xR <> ""
   xR.Resize(40, 2).Copy xA
   Set xR = xR(41): Set xA = xA(1, 3)
   If xA.Column = 7 Then Set xA = xA(41, -5)
Loop
End Sub

---

作者: wsx1130    時間: 2023-1-17 21:46

回復 2# 准提部林
準大真的好厲害，我用for 一直卡關，循環到一直當，您的邏輯真的很厲害
幾行就解決我的問題

---

作者: Andy2483    時間: 2023-1-18 08:04

本帖最後由 Andy2483 於 2023-1-18 08:18 編輯

回復 1# wsx1130


    謝謝前輩發表此主題與範例
謝謝 准提部林前輩指導
以下是後學學習心得,請前輩參考,請各位前輩再指導

Option Explicit
Sub TEST_A1()
Dim xA As Range, xR As Range
'↑宣告變數:(xA,xR)是儲存格變數
Intersect(ActiveSheet.UsedRange, Range("a:f")).Offset(2, 0).Clear
'↑令交集的範圍儲存格 往下偏移2列範圍 清除
'交集的範圍儲存格: 操作表已使用的儲存格範圍 與[A:F]欄儲存格重疊的儲存格
,https://learn.microsoft.com/zh-tw/office/vba/api/excel.application.intersect
Application.ScreenUpdating = False
'↑令螢幕畫面暫不隨程序做變化
Set xA = [a3]:  Set xR = [k2]
'↑令xA這儲存格變數是 儲存格[A3] :令xR這儲存格變數是 儲存格[K2]
Do While xR <> ""
'↑設條件迴圈(當xR變數值不是空字元!就繼續執行)
'https://learn.microsoft.com/zh-tw/dotnet/visual-basic/language-reference/statements/do-loop-statement
   xR.Resize(40, 2).Copy xA
   '↑令xR變數擴展向下40列,向右擴展2欄的範圍儲存格複製到 xA變數
   Set xR = xR(41): Set xA = xA(1, 3)
   '↑令xR變數換成是 自身(含)往下41列位置儲存格
   '令xA變數換成是 自身(含)往右3欄位置儲存格
   'xR(41) = xR(41,1) = xR.Item(41, 1)
   If xA.Column = 7 Then Set xA = xA(41, -5)
   '↑如果xA變數的欄號是7 (G欄)!
   '就令xA變數換成是 自身(含)往下41列/往左7欄位置儲存格
   '自身(含)是1,往左7欄:(-5,-4,-3,-2,-1,0,1)
   '(A,B,C,D,E,F,G)
Loop
End Sub

---

作者: Andy2483    時間: 2023-1-18 12:31

回復 1# wsx1130


    以下是後學練習留空白在下方的方法,請前輩參考

執行結果 最後頁:
[attach]35754[/attach]

Option Explicit
Sub TEST_A2()
Dim xA As Range, xR As Range, R%
Intersect(ActiveSheet.UsedRange, Range("a:f")).Offset(2, 0).Clear
ActiveSheet.ResetAllPageBreaks
Application.ScreenUpdating = False
R = 40:  Set xA = [a3]:  Set xR = [k2]
Head:
Do While xR <> ""
   If xA.Column = 7 Then
      Set xA = xA(R + 1, -5)
      xA.PageBreak = xlPageBreakManual
      If xR(R * 3) = "" Then
         R = (Cells(Rows.Count, "K").End(3).Row - 1) Mod R * 3
         R = IIf(R Mod 3, R \ 3 + 1, R \ 3)
         GoTo Head
      End If
   End If
   xR.Resize(R, 2).Copy xA
   Set xR = xR(R + 1): Set xA = xA(1, 3)
Loop
ActiveSheet.PageSetup.PrintArea = Range([F1], Cells(Rows.Count, "A").End(3)).Address
End Sub

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)