- 帖子
- 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
試試看：
 - '由輸入到輸出
- Private Sub CommandButton1_Click()
- Dim sh1, sh2, sh3 As Worksheet
- Dim r1, i, lastRow1, lastRow2, lastRow3, msg As Integer
- Dim 客戶 As String
- Set sh1 = Sheets("輸入")
- Set sh2 = Sheets("輸出")
- Set sh3 = Sheets("歷史")
-
- sh2.Cells.Clear '全部清除 "輸出"
- sh2.ResetAllPageBreaks '重設所有的分頁線
-
- sh1.Rows("1:1").Copy sh2.Rows("1:1") '複製 "輸入"的標題列 到 "輸出"
- lastRow1 = sh1.[A65536].End(xlUp).Row '取得 "輸入"的欄A 最下面非空白列 的列號
- lastRow3 = sh3.[A65536].End(xlUp).Row '取得 "歷史" A欄最下面非空白列 列號
-
-
- '//////
- '建立"輸出"的不重覆客戶名單
- '不重覆篩選, 將結果複製 欄G(假定 "輸入"欄G 以後沒資料)
- Set rng = sh1.[A1].Resize(lastRow1, 1)
-
- rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rng, _
- CopyToRange:=sh1.Range("G1"), Unique:=True
-
- sh1.Columns("G:G").Copy sh2.Columns("A:A") '複製 "輸入"的欄G(篩選結果) 到 "輸出"的欄A
- sh1.Columns("G:G").Delete '刪除 "輸入"的欄G
-
- lastRow2 = sh2.[A65536].End(xlUp).Row '取得 "輸出" A欄最下面非空白列 的列號
-
- '//////
- '由下往上擴展每個客戶的工作列(每個客戶20列), 並加入分頁線
- For i = 2 To lastRow2
- sh2.HPageBreaks.Add Before:=sh2.Cells(i + 1, 1) '插入水平分頁線
- Next
- For i = lastRow2 To 2 Step -1
- sh2.Cells(i + 1, 1).Resize(19, 1).EntireRow.Insert Shift:=xlDown
- Next
-
- '//////
- '將"輸入"的 客戶資料複製到"輸出"
- For r1 = 2 To lastRow1
-
- '如果是空白格, 換下一筆
- If sh1.Cells(r1, 1) = "" Then Exit For
-
- '否則 從 "輸入" 複製客戶資料 到"輸出"
- 客戶 = sh1.Cells(r1, 1)
- 複製客戶資料 客戶, r1
- Next
-
- '//////
- '將"輸入"的 客戶資料保存到"歷史"
- sh1.[A2].Resize(lastRow1, 3).Copy sh3.Cells(lastRow1 + 1, 1)
- msg = MsgBox("已將【輸入】的客戶資料 複製到【歷史】中, " & Chr(10) _
- & "要清除【輸入】的客戶資料嗎?", vbYesNo)
- If msg = vbYes Then
- sh1.[A2].Resize(lastRow1, 3).Clear
- End If
- End Sub
- Sub 複製客戶資料(ByVal 客戶 As String, ByVal r1 As Integer)
- Dim sh1, sh2 As Worksheet
- Dim i, lastRow2 As Integer
- Dim cel, cel2, rng As Range
- Set sh1 = Sheets("輸入")
- Set sh2 = Sheets("輸出")
-
- lastRow2 = sh2.[A65536].End(xlUp).Row '取得 "輸出" A欄最下一列列號
- Set rng = sh2.[A1].Resize(lastRow2, 1) '設定"輸出"搜尋(Find)範圍
-
- '取得 "輸出"第一筆客戶 的 cel
- Set cel = rng.Find(What:=客戶, After:=sh2.[A1], LookIn:=xlValues, _
- lookat:=xlWhole, MatchByte:=True)
-
- '將 "輸出"客戶的第一筆列值 除以20, 如果餘2,
- '而且這一筆的左一格(Offset(0, 1))是空白格→尚未有客戶資料(只有客戶名稱)
- '→從"輸入" 複製客戶資料 到"輸出"
- If cel.Row Mod 20 = 2 And cel.Offset(0, 1) = "" Then
- sh1.Cells(r1, 1).Resize(1, 3).Copy cel
- Else
-
- '取得"輸出"客戶 的 最後一筆列值+1
- i = cel.Row
- Do
- i = i + 1
- Loop Until sh2.Cells(i, 1) = "" Or sh2.Cells(i, 1) <> 客戶
-
- '若 最後一筆客戶的列值+1 是空白
- '→從"輸入" 複製客戶資料 到"輸出"(含客戶名稱)
- If sh2.Cells(i, 1) = "" Then
- sh1.Cells(r1, 1).Resize(1, 3).Copy sh2.Cells(i, 1)
-
- '否則, "輸出" 最後一筆客戶的列值+1 是另一位 客戶名單,
- '→這位客戶的 空白列 已用完,
- '擴展這位客戶的空白列, 並加入分頁線
- Else
- sh2.Cells(i, 1).Resize(20, 1).EntireRow.Insert Shift:=xlDown
- sh2.HPageBreaks.Add Before:=sh2.Cells(i, 1)
- End If
- End If
- End Sub
|
|
發表於 2014-4-17 23:23
| 