用VBA开发的任务进度跟踪软件

《运用VBA开发工作任务跟踪程序》

作者：Julian Zhang

信箱：Julian_zhang@https://www.360docs.net/doc/a49459340.html,

本文含源程序及原代码，下载本文后，双击下面内嵌的Excel文档（周例会-KSM.xlsm），然后另存为…，直接应用。

应用环境为MicroSoft Excel 2007版，需要开通宏支持。

本程序在公司经过多年应用和完善，一直供高级管理层作为会议纪要使用。文件放到公司共享文件夹中，每位领导各自更新自己的任务。

会议完毕后，点击报告存档按钮，所有已经完成的任务自动移动到Finished 工作表中存档，而所有取消的任务将自动移动到Cancelled工作表中存档，两个工作表都有密码保护，没有密码不能修改。

为了简化应用，内嵌的文件密码已经都简化成了tgr，如果需要复杂的密码，或需要修改密码，可以给我发邮件。

周例会-KSM.xlsm

本文件功能强大，作者拥有完全知识产权。部分功能见下面截图：

附录：程序原代码

Option Explicit

'API functions to be used

'//////////////////////////////////////////////////////////////////// 'Password masked inputbox

'Allows you to hide characters entered in a VBA Inputbox.

'

'Code written by Daniel Klann

'//////////////////////////////////////////////////////////////////// 'API functions to be used

Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, _

ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long

Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _

(ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, _

ByVal dwThreadId As Long) As Long

Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" _

(ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _

ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, _

ByVal lpClassName As String, _

ByVal nMaxCount As Long) As Long

Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long

'Constants to be used in our API functions

Private Const EM_SETPASSWORDCHAR = &HCC

Private Const WH_CBT = 5

Private Const HCBT_ACTIVATE = 5

Private Const HC_ACTION = 0

Private hHook As Long

Public Function NewProc(ByVal lngCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim RetVal

Dim strClassName As String, lngBuffer As Long

If lngCode < HC_ACTION Then

NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)

Exit Function

End If

strClassName = String$(256, " ")

lngBuffer = 255

If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer)

If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox

'This changes the edit control so that it display the password character *.

'You can change the Asc("*") as you please.

SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0

End If

End If

'This line will ensure that any other hooks that may be in place are

'called correctly.

CallNextHookEx hHook, lngCode, wParam, lParam

End Function

Public Function InputBoxDK(Prompt, Optional Title, Optional Default, Optional XPos, _

Optional YPos, Optional HelpFile, Optional Context) As String

Dim lngModHwnd As Long, lngThreadID As Long

lngThreadID = GetCurrentThreadId

lngModHwnd = GetModuleHandle(vbNullString)

hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)

On Error Resume Next

InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook

End Function

Sub Update_Report()

' Move finished tasks to Sheet "Finished" and protect;

' Move cancelled tasks to Sheet "Cancelled" and protect;

'

' Rev. 3.0 @Julian Zhang 2013-3-23

' --------------------------------

'''' MAIN

Dim i, j, Row_count, Dlt_count, Finished_rows, Cancelled_rows, Records_Rows As Integer

Dim Sheet_name, Input_Passcode, Sys_Passcode As String

Dim strWeek, strTime, Response, strYear, Backup_fn, Backup_Path

strYear = Year(Date)

strWeek = DateDiff("ww", strYear & "-01-01", Date)

'''Constant defination

Const Index_column As Integer = 1

Const Leader_column As Integer = 3

Const Finished_rate_column As Integer = 6

Const End_column As Integer = 7

Const Start_data_row As Integer = 4

Const End_data_row As Integer = 103

Const Pass_word As String = "tgr"

'''Check file structure. The Excel file must contain "Finished", "Canceled", "Tasks" and "Projects" sheets.

If Check_structure = False Then

Exit Sub

End If

''Passcode for running the program. If Passcode is wrong, program will exit without doing anything

Sys_Passcode = CStr(Year(Date)) & CStr(Weekday(Date, vbMonday)) &

CStr(Minute(Time))

' Input_Passcode = InputBox("Please input access code(ywm):", "Safety Check")

' 上一句为以前的密码输入，更改为以下语句

If InputBoxDK("Please enter password", "Password Required") <> "tgr" Then MsgBox ("Wrong Password, Program exit!")

Exit Sub

End If

'''Remove ProtectSharing

Application.DisplayAlerts = False

Application.ScreenUpdating = False

If ActiveWorkbook.MultiUserEditing Then

ActiveWorkbook.UnprotectSharing ("tgr")

End If

'''Close multi-user editable sharing

If ActiveWorkbook.MultiUserEditing Then

ActiveWorkbook.ExclusiveAccess

End If

''' Remove passcode protection for sheets Finished, Cancelled and Tasks For Each Sheet_name In Worksheets(Array("Finished", "Cancelled", "Tasks"))

Sheet_name.Activate

ActiveSheet.Unprotect Password:=Pass_word

Next

''' Sort Ascending by Leaders.

Sheets("Tasks").Activate

If ActiveSheet.AutoFilterMode Then

ActiveSheet.Range("$A$3:$M$103").AutoFilter Field:=3,

Criteria1:=[C3].Value

ActiveWorkbook.ActiveSheet.ShowAllData

ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear

Else

ActiveSheet.Rows(3).AutoFilter

End If

ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _

Range(Cells(Start_data_row - 1, Leader_column).Address,

Cells(End_data_row, Leader_column).Address), _

SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.AutoFilter.Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Records_Rows = WorksheetFunction.CountA(Range(Cells(Start_data_row, Leader_column).Address, Cells(End_data_row, Leader_column).Address))

'''重写序号

For i = Start_data_row To End_data_row

Cells(i, Index_column) = i - 3

Next

'''Backup original tasks to new excel sheet and pdf file

Response = MsgBox("是否备份本周报告？", vbYesNo + vbDefaultButton1, "备份报告")

If Response = vbYes Then

strTime = "-" & Year(Date) & "-" & Month(Date) & "-" & Day(Date) & "-" & Hour(Time) & "-" & Minute(Time) & "-" & Second(Time)

Backup_Path = ThisWorkbook.Path & "\" & "例会备份" & "\" & strYear

Backup_fn = "Week" & strWeek & strTime

If Dir(Backup_Path & "\" & Backup_fn & ".xlsm") = Backup_fn & ".xlsm" Then

If MsgBox("备份文件已存在，是否覆盖？", vbYesNo + vbCritical + vbDefaultButton2, "提示") = vbNo Then

GoTo 101

Else

GoTo 102

End If

Else

If Dir(ThisWorkbook.Path & "\例会备份", 16) = "" Then

MkDir (ThisWorkbook.Path & "\例会备份")

MkDir (Backup_Path)

Else

If Dir(Backup_Path, 16) = "" Then

MkDir (Backup_Path)

End If

End If

102:

'''Copy Tasks sheet to a new Excel file for backup

Range("G2").Value = Date

Columns("H:M").Select

Selection.NumberFormatLocal = ";;;"

Columns("A:M").Select

Selection.Copy

Workbooks.Add

[A1].PasteSpecial Paste:=xlPasteColumnWidths

ActiveSheet.Paste

With ActiveSheet.PageSetup

.PrintTitleRows = "$1:$3"

.PrintArea = "$A$1:$G$103"

.LeftMargin = Application.InchesToPoints(0.196850393700787)

.RightMargin = Application.InchesToPoints(0.196850393700787)

.TopMargin = Application.InchesToPoints(0.354330708661417)

.BottomMargin = Application.InchesToPoints(0.354330708661417)

.CenterHorizontally = True

.CenterVertically = False

.PaperSize = xlPaperA4

.Zoom = 80

End With

Range("F:G,A:D").FormatConditions.Delete

Dim rng As Range

For Each rng In [B4:G103]

If rng <> rng.Offset(0, 6).Value Then

rng.Select

With Selection.Font

.Color = -10477568

.TintAndShade = 0

.Bold = True

End With

End If

Next rng

Columns("H:M").Select

Selection.Delete

With ActiveWorkbook

.SaveAs Filename:=Backup_Path & "\" & Backup_fn, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

.Close

End With

'''Export to a new PDF file for backup

Range("A1", Cells(Records_Rows + 3, End_column).Address).Select

Selection.ExportAsFixedFormat Type:=xlTypePDF,

Filename:=Backup_Path & "\" & Backup_fn & ".pdf", Quality:= _

xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=True, _

OpenAfterPublish:=False

End If

End If

101:

''' Sort Ascending by finishing rate.

ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Clear

ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _

Range(Cells(Start_data_row - 1, Finished_rate_column).Address,

Cells(End_data_row, Finished_rate_column).Address), _

SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal With ActiveWorkbook.ActiveSheet.AutoFilter.Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

Columns("H:M").Select

Selection.Clear

Selection.Font.Size = 1

Selection.EntireColumn.Hidden = True

'''Move Finished or Cancelled tasks to relative sheets

Finished_rows = 0

Cancelled_rows = 0

i = Start_data_row

Do While Cells(i, Finished_rate_column).Value >= 0.99

If Cells(i, Finished_rate_column).Value = 1 Then

Finished_rows = Finished_rows + 1

Else

If Cells(i, Finished_rate_column).Value = 0.99 Then

Cancelled_rows = Cancelled_rows + 1

End If

End If

i = i + 1

Loop

Dlt_count = Finished_rows + Cancelled_rows

If Dlt_count >= 1 Then

If Finished_rows >= 1 Then

Range(Cells(Start_data_row, Finished_rate_column).Address,

Cells(Start_data_row + Dlt_count - 1, Finished_rate_column).Address).Value = Date Range(Cells(Start_data_row, Index_column).Address,

Cells(Start_data_row + Finished_rows - 1, End_column).Address).Copy

Sheets("Finished").Select

Rows(https://www.360docs.net/doc/a49459340.html,edRange.Rows.Count + 1).Select

ActiveSheet.Paste

Range("A1").Activate '''Set A1 as active cell

End If

If Cancelled_rows >= 1 Then

Sheets("Tasks").Activate

Range(Cells(Start_data_row + Finished_rows, Index_column).Address, Cells(Start_data_row + Dlt_count - 1, End_column).Address).Copy

Sheets("Cancelled").Select

Rows(https://www.360docs.net/doc/a49459340.html,edRange.Rows.Count + 1).Select

ActiveSheet.Paste

Range("A1").Activate '''Set A1 as active cell

End If

Sheets("Tasks").Select

Range(Cells(Start_data_row, Index_column).Address, Cells(Start_data_row + Dlt_count - 1, End_column + 1).Address).Select

Selection.ClearComments

Selection.ClearContents

Range(Cells(Start_data_row, Finished_rate_column).Address, _

Cells(End_data_row, Finished_rate_column).Address).NumberFormatLocal = "0%"

End If

'''Password protect "Finished" and "Cancelled" sheets

For Each Sheet_name In Worksheets(Array("Finished", "Cancelled")) Sheet_name.Activate

Cells.Select

Cells.FormatConditions.Delete

With Selection.Interior

.Pattern = xlNone

.TintAndShade = 0

.PatternTintAndShade = 0

End With

For i = 3 To https://www.360docs.net/doc/a49459340.html,edRange.Rows.Count

Cells(i, Index_column) = i - 2

Next

With ActiveSheet

.Cells.Locked = True 'lock all cells

.Protect Password:=Pass_word, DrawingObjects:=True, contents:=True, Scenarios:=True, AllowInsertingColumns:=False, AllowInsertingRows _

:=False, AllowDeletingColumns:=False, AllowDeletingRows:=False, AllowFiltering:=True

End With

Next

''' Sort Ascending by name of Leaders.

Sheets("Tasks").Activate

ActiveSheet.AutoFilter.Sort.SortFields.Clear

ActiveWorkbook.ActiveSheet.AutoFilter.Sort.SortFields.Add Key:= _

Range(Cells(Start_data_row - 1, Leader_column).Address, Cells(End_data_row, Leader_column).Address), _

SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.ActiveSheet.AutoFilter.Sort

.Header = xlYes

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

For i = 1 To End_data_row - 3

Cells(i + Start_data_row - 1, Index_column) = i

Next

Range(Cells(Start_data_row, Index_column).Address, Cells(Records_Rows -

Dlt_count + Start_data_row - 1, Index_column).Address).Interior.ColorIndex = 15 Range(Cells(Records_Rows - Dlt_count + Start_data_row, Index_column).Address, Cells(End_data_row, Index_column).Address).Interior.ColorIndex = 0

Rows(Start_data_row & ":" & End_data_row).EntireRow.AutoFit

Sheets("Tasks").Activate

Cells.Select

Selection.Locked = False

Range(Cells(Start_data_row, Index_column + 1).Address, Cells(End_data_row, End_column).Address).Copy

Cells(Start_data_row, End_column + 1).PasteSpecial Paste:=xlValues

Selection.NumberFormatLocal = ";;;"

ActiveSheet.Protect Password:=Pass_word, DrawingObjects:=True,

contents:=True, Scenarios:=True, AllowFormattingCells:=False, _

AllowFormattingColumns:=False, AllowFormattingRows:=False, AllowInsertingColumns:=False, AllowInsertingRows:=False, _

AllowDeletingColumns:=False, AllowDeletingRows:=False, _

AllowSorting:=True, AllowFiltering:=True

Range("A1").Select

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

Function Check_structure() As Boolean

Dim i, j As Integer

Dim Archieve_Sh, ST_Plan_Sh As String

Check_structure = True

i = 0

For j = 1 To ThisWorkbook.Sheets.Count

If Sheets(j).Name = "Finished" Or Sheets(j).Name = "Cancelled" Or Sheets(j).Name = "Tasks" Then

i = i + 1

End If

Next

If i < 3 Then

MsgBox ("文件结构错误，缺少必要工作表")

Check_structure = False

Exit Function

End If

End Function

Sub Recover_Format()

'

' Macro1 Macro

'

'

'''Remove ProtectSharing

Application.DisplayAlerts = False

Application.ScreenUpdating = False

ActiveWorkbook.UnprotectSharing ("1234")

'''Close multi-user editable sharing

If ActiveWorkbook.MultiUserEditing Then

ActiveWorkbook.ExclusiveAccess

End If

''' Remove passcode protection for sheets Finished, Cancelled and Tasks Sheets("Tasks").Activate

ActiveSheet.Unprotect Password:="tgr"

Password.Show

Cells.FormatConditions.Delete

Columns("H:M").Select

Selection.NumberFormatLocal = ";;;"

Range("B4:G103").Select

Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=B4<>H4"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Font

.Bold = True

.Italic = False

.Color = -10477568

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = False

Range("E4:E103").Select

Selection.FormatConditions.Add Type:=xlExpression,

Formula1:="=E4

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior

.PatternColorIndex = xlAutomatic

.Color = 255

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = True

Range("E4:E103").Select

Selection.FormatConditions.Add Type:=xlExpression,

Formula1:="=E4>=TODAY()"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior

.PatternColorIndex = xlAutomatic

.Color = 49407

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = True

Range("E4:E103").Select

Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=F4=99%" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior

.Pattern = xlGray8

.PatternColor = 255

.ColorIndex = xlAutomatic

.PatternTintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = True

Range("E4:E103").Select

Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=F4=100%" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Interior

.PatternColorIndex = xlAutomatic

.Color = 5287936

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = True

Range("E4:E103").Select

Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=C4=""""" Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority Selection.FormatConditions(1).StopIfTrue = True

Rows("4:103").EntireRow.AutoFit

Range("A3:G103").Select

With Selection

.VerticalAlignment = xlCenter

.WrapText = True

.Orientation = 0

.AddIndent = False

.ShrinkToFit = False

.ReadingOrder = xlContext

.MergeCells = False

End With

Range("B4:G103").Select

Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=B4<>H4"

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority With Selection.FormatConditions(1).Font

.Bold = True

.Italic = False

.Color = -10477568

.TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = False

Cells.Select

Selection.Locked = False

ActiveSheet.Protect Password:="tgr", DrawingObjects:=True, contents:=True, Scenarios:=True, AllowFormattingCells:=False, _

AllowFormattingColumns:=False, AllowFormattingRows:=False, AllowInsertingColumns:=False, AllowInsertingRows:=False, _

AllowDeletingColumns:=False, AllowDeletingRows:=False, _

AllowSorting:=True, AllowFiltering:=True

Range("A1").Select

MsgBox "Worksheet is successfully formated"

End Sub