返回列表 上一主題 發帖

[發問] 分頁次的vba寫法

melvinhsu

帖子
14 
主題
4 
精華
0 
積分
18 
點名
0  
作業系統
WINDOWS 
軟體版本
VISTA 
閱讀權限
10 
註冊時間
2010-9-10 
最後登錄
2015-1-6 

論壇贊助勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 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

帖子
14 
主題
4 
精華
0 
積分
18 
點名
0  
作業系統
WINDOWS 
軟體版本
VISTA 
閱讀權限
10 
註冊時間
2010-9-10 
最後登錄
2015-1-6 

論壇贊助勳章
5#
發表於 2014-5-9 16:40 | 只看該作者
謝謝2位的回應。指導

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
255  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-25 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

yen956

帖子
522 
主題
36 
精華
1 
積分
603 
點名
0  
作業系統
win xp sp3 
軟體版本
Office 2003 
閱讀權限
50 
性別
男 
註冊時間
2012-12-13 
最後登錄
2021-7-11 
3#
發表於 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
複製代碼

TOP

melvinhsu

帖子
14 
主題
4 
精華
0 
積分
18 
點名
0  
作業系統
WINDOWS 
軟體版本
VISTA 
閱讀權限
10 
註冊時間
2010-9-10 
最後登錄
2015-1-6 

論壇贊助勳章
2#
發表於 2014-4-14 18:58 | 只看該作者
回復 1# melvinhsu


板大，再煩確認附件。

活頁簿12.zip (25.42 KB)

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
返回列表 上一主題