- 帖子
- 129
- 主題
- 25
- 精華
- 0
- 積分
- 159
- 點名
- 0
- 作業系統
- win7
- 軟體版本
- office2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2011-12-24
- 最後登錄
- 2022-12-12
|
15#
發表於 2014-2-3 11:23
| 只看該作者
- Option Explicit '必須置於模組頂端 強制宣告變數
- Private Sub CommandButton1_Click()
- Dim Sh As Worksheet, i As Integer, ii As Integer, r As Integer, Ar 'Dim 宣告變數
- Dim k As Integer
-
- Application.DisplayAlerts = False
- Application.ScreenUpdating = False
- For Each Sh In Sheets
- If Sh.Name <> "工作表1" And Sh.Name <> "工作表2" And Sh.Name <> "表格範本" Then Sh.Delete
- '活頁簿只留 工作表1:是輸入區,工作表2:是歷史記錄 ,"表格範本"
- Next
-
- With Sheets("工作表2")
- If .UsedRange.Rows.Count = 1 Then '沒有歷史紀錄
- '.UsedRange.Rows.Count = 1
- Sheets("工作表1").UsedRange.Copy '複製(含標頭)
- .Range("A1").PasteSpecial xlPasteValues
-
- Else
- Sheets("工作表1").UsedRange.Offset(1).Copy '複製(不含標頭)
- Sheets("工作表2").Range("A" & .UsedRange.Rows.Count).Offset(3).PasteSpecial xlPasteValues
- 'Offset(3) :空2列->第3列貼上
-
- End If
-
-
- End With
-
-
- With Sheets("工作表1")
-
- .UsedRange.Range("E:E").AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True
- '進階篩選 E欄 不重複資料到工作表最右欄 ***取得類別的分類***
- 'AdvancedFilter:進階篩選
- 'xlFilterCopy:進階篩選的資料顯示在其他地方
- '.Cells(1, .Columns.Count) ->工作表的最右欄第1個儲存格->進階篩選的資料顯示的地方
-
- i = 2
- Do While .Cells(i, .Columns.Count) <> "" '工作表最右欄的儲存格 <>""
- .Range("A:E").AutoFilter 5, .Cells(i, .Columns.Count) 'AutoFilter: 自動篩選 ,第5欄(類別)的準則為 .Cells(i, .Columns.Count)
- Sheets("表格範本").Copy , Sheets(Sheets.Count)
- Set Sh = ActiveSheet
- Sh.[a1] = .Cells(i, .Columns.Count) & "支出表"
- Sh.Name = .Cells(i, .Columns.Count)
- r = 5
- For Each Ar In .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows '篩選出的資料列
- If r = 17 Then
- r = 6
- Sh.Copy , Sheets(Sheets.Count)
- Set Sh = ActiveSheet
- Sh.Range("A6:E16") = ""
- End If
- Sh.Cells(r, "a").Resize(, Ar.Columns.Count) = Ar.Value 'Index(AR, ii) :讀取陣列
- r = r + 1
- Next
- i = i + 1
- Loop
-
- k = 1
- Do While .Cells(k, .Columns.Count) <> ""
- .Cells(k, .Columns.Count) = ""
- k = k + 1
- Loop
-
- '.Cells(1, .Columns.Count).CurrentRegion = ""
- .AutoFilterMode = False
- End With
- Application.ScreenUpdating = True
- Me.Activate
- End Sub
複製代碼 回復 14# iceandy6150
我試出來了,貼上代碼及附檔
感謝G大熱心教學
只要在工作表1,輸入資料,按下按鈕,就能自動產生相對應的工作表
並將資料分類好放到相對應的工作表內,可供使用者直接列印出來
而每次動作也會記錄在工作表2中,當作歷史紀錄 |
-
-
ttt.rar
(19.09 KB)
完成檔
|