wsx1130

帖子: 51
主題: 11
精華: 0
積分: 110
點名: 0
作業系統: win 10
軟體版本: office 2007
閱讀權限: 20
註冊時間: 2017-7-15
最後登錄: 2024-10-27

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 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
....到最後

test1.rar (62.5 KB)

樓主熱帖

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

5^#

發表於 2023-1-18 12:31 | 只看該作者

回復 1# wsx1130

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

執行結果最後頁:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

4^#

發表於 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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

wsx1130

中學生 Rank: 2

帖子: 51
主題: 11
精華: 0
積分: 110
點名: 0
作業系統: win 10
軟體版本: office 2007
閱讀權限: 20
註冊時間: 2017-7-15
最後登錄: 2024-10-27

3^#

發表於 2023-1-17 21:46 | 只看該作者

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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-21

2^#

發表於 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

TOP