VBA-考勤報表
Sub Auto_NewSheet()
記錄開始時間
begin_t = Timer
關閉彈窗
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
修改默認打開路勁
d = Mid(ThisWorkbook.Path, 1, 1) 獲取本系統驅動器盤位置
L = ThisWorkbook.Path 定義本工作簿的路經
ChDrive d
ChDir L
記錄本表名字
Dim myWBName As String
myWBName = ThisWorkbook.Name
mySh1Name = Workbooks(myWBName).Sheets(1).Name
mySh2Name = Workbooks(myWBName).Sheets(2).Name
mySh3Name = Workbooks(myWBName).Sheets(3).Name
mySh4Name = Workbooks(myWBName).Sheets(4).Name
用戶輸入月份
Dim New_month
On Error GoTo errorhandle:
New_month = InputBox("輸入新建年月份 例:Jan 2018", "快輸入")
新建Demo文件
Worksheets(mySh4Name).Copy after:=Workbooks(myWBName).Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = New_month
myNewShName = Sheets(Sheets.Count).Name
打開彈窗
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
記錄結束時間
end_t = Timer
運行計算時間
Dim h, s, m As Integer
小時
h = Int((end_t - begin_t) / 3600)
分鐘
s = Int(((end_t - begin_t) - 3600 * h) / 60)
秒
m = end_t - begin_t - h * 3600 - s * 60
MsgBox "已完成填寫!!!請檢查!!!" & "運行時間:" & h & "時" & s & "分" & m & "秒"
End Sub
Option Compare Text 以文本方式比較,不區分大小寫（此語句必須寫在所有過程之前，不可以在Sub中定義，否則報錯）
Sub Auto_DisposalData()
記錄開始時間
begin_t = Timer
關閉彈窗
Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
修改默認打開路勁
d = Mid(ThisWorkbook.Path, 1, 1) 獲取本系統驅動器盤位置
L = ThisWorkbook.Path 定義本工作簿的路經
ChDrive d
ChDir L
記錄本表名字
Dim myWBName As String
myWBName = ThisWorkbook.Name
mySh1Name = Workbooks(myWBName).Sheets(1).Name
mySh2Name = Workbooks(myWBName).Sheets(2).Name
mySh3Name = Workbooks(myWBName).Sheets(3).Name
mySh4Name = Workbooks(myWBName).Sheets(4).Name
myNewShName = ActiveSheet.Name
清理下本表數據
Workbooks(myWBName).Sheets(mySh1Name).Columns("A:H").Clear
Workbooks(myWBName).Sheets(mySh2Name).Range("A2:H65536").Clear
打開考勤匯總表
Dim fileToOpenBD, fileToOpenINV, BD_WBName, INV_WBName
打開基礎數據表
MsgBox ("請打開<基礎數據表>")
fileToOpenBD = Application.GetOpenFilename()
Workbooks.Open (fileToOpenBD)
BD_WBName = ActiveWorkbook.Name
複製A到E列
Workbooks(BD_WBName).Sheets(1).Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
ActiveWorkbook.Sheets("匯總").Columns("A:A").Select
Range(Selection, Selection.End(xlToRight)).Select
Application.CutCopyMode = False
Selection.Copy
Windows(myWBName).Activate
Sheets(mySh1Name).Select
Range("a1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
關閉文件
Workbooks(BD_WBName).Close False
整理BasicData
Workbooks(myWBName).Sheets(mySh1Name).Select
添加標題
Sheets(mySh1Name).Cells(1, 6) = "上班"
Sheets(mySh1Name).Cells(1, 7) = "遲到"
Sheets(mySh1Name).Cells(1, 8) = "下班"
計算最後一行
Dim BD_EndRow As Integer
BD_EndRow = Sheets(mySh1Name).Range("A65536").End(xlUp).Row
填寫
For BD_i = 2 To BD_EndRow
Sheets(mySh1Name).Cells(BD_i, 6) = Left(Cells(BD_i, 5), 5)
If Sheets(mySh1Name).Cells(BD_i, 6) > Sheets(mySh1Name).Cells(2, 10) Then
Sheets(mySh1Name).Cells(BD_i, 7) = Sheets(mySh1Name).Cells(BD_i, 6) - Sheets(mySh1Name).Cells(2, 10)
End If
Sheets(mySh1Name).Cells(BD_i, 8) = Right(Cells(BD_i, 5), 5)
Next
調整G列格式
Columns("G:G").Select
Selection.NumberFormatLocal = "h:mm;@"
Dim BD_e, BD_f, BD_g, BD_h As Range
Set BD_e = Sheets(mySh1Name).Range("E2:E" & BD_EndRow)
Set BD_f = Sheets(mySh1Name).Range("F2:F" & BD_EndRow)
Set BD_g = Sheets(mySh1Name).Range("G2:G" & BD_EndRow)
Set BD_h = Sheets(mySh1Name).Range("H2:H" & BD_EndRow)
BD_f = Left(Cells(BD_i, 5), 5)
整理DisposalData
日期&星期
Sheets(mySh1Name).Range("D2:D" & BD_EndRow).Select
Selection.Copy
Sheets(mySh2Name).Select
Range("A2:B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
第1列日期整理
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
第二列星期整理
Sheets(mySh2Name).Columns("B:B").Select
Selection.NumberFormatLocal = "ddd"
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
姓名
Sheets(mySh1Name).Select
Sheets(mySh1Name).Range("B2:B" & BD_EndRow).Select
Selection.Copy
Sheets(mySh2Name).Select
Range("c2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
上班/遲到/下班
Sheets(mySh1Name).Select
Sheets(mySh1Name).Range("F2:H" & BD_EndRow).Select
Selection.Copy
Sheets(mySh2Name).Select
Range("E2").Select
ActiveSheet.Paste
查找員工
Dim cel1 As Range, cel2 As Range, cel3 As Range
Dim i%
Dim P_EndRow As Integer
P_EndRow = Sheets(mySh3Name).[A65536].End(xlUp).Row
Sheets(mySh2Name).Activate
For Each cel1 In Sheets(mySh2Name).Range("c2:c" & BD_EndRow)
For Each cel2 In Sheets(mySh3Name).Range("b2:b" & P_EndRow)
If cel1.Value = cel2.Value Then
cel1.Offset(0, 1).Value = cel2.Offset(0, 1)
cel1.Offset(0, 5).Value = cel2.Offset(0, -1)
End If
Next
Next
備註列排序
Columns("A:H").Select
ActiveWorkbook.Worksheets("DisposalData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("DisposalData").Sort.SortFields.Add Key:=Range( _
"H2:H65537"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("DisposalData").Sort
.SetRange Range("A1:H65537")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
刪除缺失值的行
Dim DD_RM_EndRow As Integer, DD_AA_EndRow As Integer
DD_RM_EndRow = Sheets(mySh2Name).[h65536].End(xlUp).Row + 1
DD_AA_EndRow = Sheets(mySh2Name).[A65536].End(xlUp).Row
Rows(DD_RM_EndRow & ":" & DD_AA_EndRow).Select
Selection.Delete Shift:=xlUp
最終排序
Columns("A:H").Select
ActiveWorkbook.Worksheets("DisposalData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("DisposalData").Sort.SortFields.Add Key:=Range( _
"A2:A65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
ActiveWorkbook.Worksheets("DisposalData").Sort.SortFields.Add Key:=Range( _
"H2:H65536"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("DisposalData").Sort
.SetRange Range("A1:H65536")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("H2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
將休息的遲到清零
Dim cel4 As Range, wd As Integer 定義周幾
For Each cel4 In Sheets(mySh2Name).Range("a2:a" & [A65536].End(xlUp).Row)
wd = Weekday(cel4, vbMonday)
If wd > 5 Then
cel4.Offset(0, 5).Clear
End If
Next
更新報表
Worksheets(mySh2Name).Range("A2:h" & DD_RM_EndRow - 1).Copy Destination:=Worksheets(myNewShName).Range("A14")
Worksheets(myNewShName).Select
Range("A14").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
格式刷
Range("A14:H14").Select
Selection.Copy
Range("A15:H" & DD_RM_EndRow + 11).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
提取分鐘數
J列
Dim myMin As Integer
For myMin = 14 To Sheets(myNewShName).[A65536].End(xlUp).Row
Sheets(myNewShName).Range("J" & myMin) = Minute(Sheets(myNewShName).Range("F" & myMin))
Next
Worksheets(myNewShName).Select
Range("A14:H14").Select
Selection.CopyFormat
Rows("A14:H" & DD_RM_EndRow + 14 - 3).Select
Selection.PasteFormat
mySh1Name = Workbooks(myWBName).Sheets(1).Name
mySh2Name = Workbooks(myWBName).Sheets(2).Name
mySh3Name = Workbooks(myWBName).Sheets(3).Name
mySh4Name = Workbooks(myWBName).Sheets(4).Name
myNewShName = ActiveSheet.Name
打開彈窗
Application.DisplayAlerts = True
Application.AskToUpdateLinks = True
Application.ScreenUpdating = True
記錄結束時間
end_t = Timer
運行計算時間
Dim h, s, m As Integer
小時
h = Int((end_t - begin_t) / 3600)
分鐘
s = Int(((end_t - begin_t) - 3600 * h) / 60)
秒
m = end_t - begin_t - h * 3600 - s * 60
MsgBox "已完成填寫!!!請檢查!!!" & "運行時間:" & h & "時" & s & "分" & m & "秒"
End Sub
推薦閱讀：
※VBA數組用法
※巧用EXCEL中的排名函數，輕鬆計算公司業績排名，幫你節省工作量！
※Excel函數公式：含金量超高的3個合併單元格實用技巧，必須掌握
※Excel VBA 基礎(03.4) - Excel對象模型之Workbook/Worksheet(一)
※怎樣才算熟練使用Excel？
TAG:VBA |