Board logo

標題: [發問] 分頁次的vba寫法 [打印本頁]
作者: melvinhsu    時間: 2014-4-14 13:25     標題: 分頁次的vba寫法

各位好，這裡想請教各位如何編寫下列的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    時間: 2014-4-14 18:58

回復 1# melvinhsu


板大，再煩確認附件。

[attach]18016[/attach]
作者: yen956    時間: 2014-4-17 15:38

回復 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


  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    時間: 2014-4-17 23:23

回復 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    時間: 2014-5-9 16:40

謝謝2位的回應。指導



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