- 帖子
- 522
- 主題
- 36
- 精華
- 1
- 積分
- 603
- 點名
- 0
- 作業系統
- win xp sp3
- 軟體版本
- Office 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2012-12-13
- 最後登錄
- 2021-7-11
|
試試看:
VBA code:
Option Explicit
Sub 清除資料()
Dim i, msg As Integer, x, sh As Worksheet
Set x = Sheets("輸入")
Application.DisplayAlerts = False
'若將工作頁命名為 "輸入","歷史","廠商類","員工類","公司類","廠商類(1)","廠商類(2)",...
'則可依 Len(Sh.Name) 決定 Delete 或 Clearcontents
For Each sh In Sheets
If Len(sh.Name) > 3 Then
sh.Delete
ElseIf Len(sh.Name) = 3 Then
sh.Range("A2:E11").ClearContents
End If
Next
'清除篩選區的資料
x.Range("G:K").Clear
'是否清除輸入區的資料?
msg = MsgBox("要清除輸入區的資料嗎?", vbYesNo)
If msg = vbYes Then
x.Range("A2:E" & x.UsedRange.Rows.Count).ClearContents
End If
End Sub
Sub 存入歷史紀錄()
Dim i, msg As Integer, sh, x, y As Worksheet
Dim 舊日期, 新日期 As Date
Set x = Sheets("輸入")
Set y = Sheets("歷史")
Application.ScreenUpdating = False
'如果尚未有歷史紀錄(第一次), 從 "輸入" 複製到 "歷史" (含標頭)
If y.UsedRange.Rows.Count = 1 Then
x.Range("A1:E" & x.UsedRange.Rows.Count).Copy
y.Range("A1").PasteSpecial xlPasteValues
Else
舊日期 = y.Range("A" & y.UsedRange.Rows.Count)
新日期 = x.Range("A" & x.UsedRange.Rows.Count)
'注意："輸入"頁 A欄(即日期欄), 應設定 資料驗証, 並設為 "日期",
'否則 If 舊日期 < 新日期 Then 會判斷錯誤!!
'從 "輸入"頁 複製到 "歷史"頁 (不含標頭, 且空2列)
If 舊日期 < 新日期 Then
x.Range("A2:E" & x.UsedRange.Rows.Count).Copy
y.Range("A" & y.UsedRange.Rows.Count + 3).PasteSpecial xlPasteValues
Else
msg = MsgBox(DateValue(新日期) & " 已經存過了!!", vbOKOnly)
End If
End If
Application.ScreenUpdating = True
End Sub
Sub 篩選資料()
Dim i, UsedRow As Integer, x, sh, shOld As Worksheet
Dim shName
shName = Array("廠商類", "公司類", "員工類")
Set x = Sheets("輸入")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'因為 "廠商類"、"公司類"、"員工類" 只有每天使用，
'列印後就可以清空舊資料, 故應依 "輸入" 篩選, 而不是依 "歷史"
For i = 0 To 2
Set sh = Sheets(shName(i))
x.Activate
'將進階篩選的 篩選準則 填入 x.[F3]
x.[F3] = Left(shName(i), 2)
'進階篩選 A:E欄 重複資料到 "G1" ***測試用(多筆重複)***
x.Range("A1:E" & x.UsedRange.Rows.Count).AdvancedFilter xlFilterCopy, x.Range("F2:F3"), x.Range("G1:K1"), False
'進階篩選 A:E欄 不重複資料到 "G1" ***實際用(不重複)***
'x.Range("A1:E" & x.UsedRange.Rows.Count).AdvancedFilter xlFilterCopy, x.Range("F2:F3"), x.Range("G1:K1"), True
'將 篩選結果 複製到對應的類別工作表
x.Range("G:K").Copy
sh.[A1].PasteSpecial xlPasteValues
Do While sh.[A12] <> "" '直到對應的類別工作表[A12] = ""
sh.Copy After:=Sheets(Sheets.Count) '1 複製原工作表
sh.Rows("12:" & sh.Rows.Count).Delete '2 將原工作表12列以下刪除(保留10列)
Set shOld = sh '3 將 shOld 設給原工作表
Set sh = Sheets(Sheets.Count) '4 將 sh 設給新工作表
sh.Rows("2:11").Delete '5 刪除新工作表 2:11 列
shOld.[A1:E11].Copy '6 複製原工作表的 格式 到新工作表
sh.[A1].PasteSpecial xlPasteFormats
Loop
Next
Application.ScreenUpdating = True
End Sub |
|
發表於 2014-2-5 00:08
| 
