[發問] 分頁次的vba寫法

melvinhsu

各位好，這裡想請教各位如何編寫下列的vba


1.a/b/c 分別代表客戶代號

2. ex. a  有2筆資料 ;b 有5筆資料 ；c有1筆資料

3. 在vba 的巨集執行後。可將  a 的2列 捉入"worksheet (2)" 的第1頁 ， b的5列捉入worksheet(2) 的第2頁 。依次類推，

note .

a. 在每頁的列數設定為20列

b. 如某一個客戶超出一頁次的呈現 ，相同下一個客戶以接續上方客戶最後頁次的下一頁次。

感謝各位先進

melvinhsu

回復 1# melvinhsu


板大，再煩確認附件。

活頁簿12.zip (25.42 KB)

下載次數: 31

2014-4-14 18:58

yen956

回復 1# melvinhsu
試試看：

1. '由輸入到輸出
   
2. Private Sub CommandButton1_Click()
   
3.     Dim sh1, sh2, sh3 As Worksheet
   
4.     Dim r1, i, lastRow1, lastRow2, lastRow3, msg As Integer
   
5.     Dim 客戶 As String
   
6.     Set sh1 = Sheets("輸入")
   
7.     Set sh2 = Sheets("輸出")
   
8.     Set sh3 = Sheets("歷史")
   
9.    
   
10.     sh2.Cells.Clear    '全部清除 "輸出"
    
11.     sh2.ResetAllPageBreaks    '重設所有的分頁線
    
12.    
    
13.     sh1.Rows("1:1").Copy sh2.Rows("1:1")   '複製 "輸入"的標題列 到 "輸出"
    
14.     lastRow1 = sh1.[A65536].End(xlUp).Row    '取得 "輸入"的欄A 最下面非空白列 的列號
    
15.     lastRow3 = sh3.[A65536].End(xlUp).Row    '取得 "歷史" A欄最下面非空白列 列號
    
16.    
    
17.    
    
18.     '//////
    
19.     '建立"輸出"的不重覆客戶名單
    
20.     '不重覆篩選, 將結果複製 欄G(假定 "輸入"欄G 以後沒資料)
    
21.     Set rng = sh1.[A1].Resize(lastRow1, 1)
    
22.    
    
23.     rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rng, _
    
24.           CopyToRange:=sh1.Range("G1"), Unique:=True
    
25.          
    
26.     sh1.Columns("G:G").Copy sh2.Columns("A:A")   '複製 "輸入"的欄G(篩選結果) 到 "輸出"的欄A
    
27.     sh1.Columns("G:G").Delete     '刪除 "輸入"的欄G
    
28.    
    
29.     lastRow2 = sh2.[A65536].End(xlUp).Row    '取得 "輸出" A欄最下面非空白列 的列號
    
30.    
    
31.     '//////
    
32.     '由下往上擴展每個客戶的工作列(每個客戶20列), 並加入分頁線
    
33.     For i = 2 To lastRow2
    
34.         sh2.HPageBreaks.Add Before:=sh2.Cells(i + 1, 1)     '插入水平分頁線
    
35.     Next
    
36.     For i = lastRow2 To 2 Step -1
    
37.         sh2.Cells(i + 1, 1).Resize(19, 1).EntireRow.Insert Shift:=xlDown
    
38.     Next
    
39.    
    
40.     '//////
    
41.     '將"輸入"的 客戶資料複製到"輸出"
    
42.     For r1 = 2 To lastRow1
    
43.    
    
44.         '如果是空白格, 換下一筆
    
45.         If sh1.Cells(r1, 1) = "" Then Exit For
    
46.         
    
47.         '否則 從 "輸入" 複製客戶資料 到"輸出"
    
48.         客戶 = sh1.Cells(r1, 1)
    
49.         複製客戶資料 客戶, r1
    
50.     Next
    
51.    
    
52.     '//////
    
53.     '將"輸入"的 客戶資料保存到"歷史"
    
54.     sh1.[A2].Resize(lastRow1, 3).Copy sh3.Cells(lastRow1 + 1, 1)
    
55.     msg = MsgBox("已將【輸入】的客戶資料 複製到【歷史】中, " & Chr(10) _
    
56.           & "要清除【輸入】的客戶資料嗎?", vbYesNo)
    
57.     If msg = vbYes Then
    
58.         sh1.[A2].Resize(lastRow1, 3).Clear
    
59.     End If
    
60. End Sub
    
61. 
    
62. 
    
63. Sub 複製客戶資料(ByVal 客戶 As String, ByVal r1 As Integer)
    
64.     Dim sh1, sh2 As Worksheet
    
65.     Dim i, lastRow2 As Integer
    
66.     Dim cel, cel2, rng As Range
    
67.     Set sh1 = Sheets("輸入")
    
68.     Set sh2 = Sheets("輸出")
    
69.    
    
70.     lastRow2 = sh2.[A65536].End(xlUp).Row     '取得 "輸出" A欄最下一列列號
    
71.     Set rng = sh2.[A1].Resize(lastRow2, 1)    '設定"輸出"搜尋(Find)範圍
    
72.    
    
73.     '取得 "輸出"第一筆客戶 的 cel
    
74.     Set cel = rng.Find(What:=客戶, After:=sh2.[A1], LookIn:=xlValues, _
    
75.           lookat:=xlWhole, MatchByte:=True)
    
76.       
    
77.     '將 "輸出"客戶的第一筆列值 除以20, 如果餘2,
    
78.     '而且這一筆的左一格(Offset(0, 1))是空白格→尚未有客戶資料(只有客戶名稱)
    
79.     '→從"輸入" 複製客戶資料 到"輸出"
    
80.     If cel.Row Mod 20 = 2 And cel.Offset(0, 1) = "" Then
    
81.         sh1.Cells(r1, 1).Resize(1, 3).Copy cel
    
82.     Else
    
83.          
    
84.         '取得"輸出"客戶 的 最後一筆列值+1
    
85.         i = cel.Row
    
86.         Do
    
87.             i = i + 1
    
88.         Loop Until sh2.Cells(i, 1) = "" Or sh2.Cells(i, 1) <> 客戶
    
89.         
    
90.         '若 最後一筆客戶的列值+1 是空白
    
91.         '→從"輸入" 複製客戶資料 到"輸出"(含客戶名稱)
    
92.         If sh2.Cells(i, 1) = "" Then
    
93.             sh1.Cells(r1, 1).Resize(1, 3).Copy sh2.Cells(i, 1)
    
94.             
    
95.         '否則, "輸出" 最後一筆客戶的列值+1 是另一位 客戶名單,
    
96.         '→這位客戶的 空白列 已用完,
    
97.         '擴展這位客戶的空白列, 並加入分頁線
    
98.         Else
    
99.             sh2.Cells(i, 1).Resize(20, 1).EntireRow.Insert Shift:=xlDown
    
100.             sh2.HPageBreaks.Add Before:=sh2.Cells(i, 1)
     
101.         End If
     
102.     End If
     
103. End Sub

複製代碼

Hsieh

回復 2# melvinhsu

1. Sub ex()
   
2. Dim A As Range
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. With Sheets(1)
   
5. For Each A In .Range(.[A2], .[A2].End(xlDown))
   
6.   If IsEmpty(d(A.Value)) Then
   
7.      Set d(A.Value) = A.Resize(, 3)
   
8.      Else
   
9.      Set d(A.Value) = Union(d(A.Value), A.Resize(, 3))
   
10.   End If
    
11. Next
    
12. End With
    
13. With Sheets(2)
    
14. .UsedRange.Offset(1).Clear '清空原有資料
    
15. r = 2
    
16. For Each ky In d.keys
    
17. r = IIf(i = 0, 2, 1)
    
18. d(ky).Copy .Cells(r + i * 20, 1) '複製到工作表2
    
19. k = Int(d(ky).Count / 3 / 20) '計算所占頁數
    
20. i = i + k + 1
    
21. Next
    
22. End With
    
23. End Sub

複製代碼

melvinhsu

謝謝2位的回應。指導