从清单生成紧急、重要、次要、琐事4类清单，督促办理
' --------------------------------------------------------------------------------
' 用来从清单生成紧急、重要、次要、琐事4类清单，督促办理
' 作者：wishmo@tom.com
' 日期：2017年4月25日
' --------------------------------------------------------------------------------
' Sheet1第一行表头，至少包括以下几列
' 序号 主题 分项任务 详细说明 结果描述 联络人 提出时间 截止时间 完成时间 重要 紧急 备注
' --------------------------------------------------------------------------------
' 从本工作表生成数据库连接
' 作者：wishmo@tom.com
' 日期：2017年4月25日
' --------------------------------------------------------------------------------
Function connect()
Dim conn As Object, PathStr As String, strConn As String, strSQL As String
Set conn = CreateObject("ADODB.Connection")
PathStr = ThisWorkbook.FullName '设置工作簿的完整路径和名称
Select Case Application.Version * 1 '设置连接字符串,根据版本创建连接
Case Is <= 11
strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
Case Is >= 12
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
End Select
conn.Open strConn
Set connect = conn
End Function
' --------------------------------------------------------------------------------
' 删除工作表、新建工作表
' 作者：wishmo@tom.com
' 日期：2017年4月25日
' --------------------------------------------------------------------------------
Function renewSheet(shtname)
On Error Resume Next
Application.DisplayAlerts = False
Set sht = Sheets(shtname)
If Not IsNull(sht) Then
sht.Delete
End If
Set sht = Sheets.Add()
sht.Name = shtname
Set renewSheet = sht
Application.DisplayAlerts = True
End Function
' --------------------------------------------------------------------------------
' 在指定的工作表中填充4类事项
' 作者：wishmo@tom.com
' 日期：2017年4月25日
' --------------------------------------------------------------------------------
Sub divide(conn, targetShtName)
'On Error Resume Next
Dim firstrow As Integer, rst As Object
Dim title(5) As String, cindex(5) As Integer, mode As Integer, i As Integer
Dim SQL(5) As String, pre As String
pre = "select 序号,主题,分项任务,详细说明,结果描述,联络人,提出时间,截止时间,备注 from [Sheet1$A1:M100] where 分项任务 is not null and 完成时间 is null and "
SQL(0) = pre + " len(重要) > 0 and len(紧急) >0"
SQL(1) = pre + " len(重要) > 0 and 紧急 is null"
SQL(2) = pre + " 重要 is null and len(紧急) > 0 "
SQL(3) = pre + " 重要 is null and 紧急 is null "
SQL(4) = "select 序号,主题,分项任务,详细说明,结果描述,联络人,提出时间,截止时间,备注 from [Sheet1$A1:M100] where 完成时间 is not null"
cindex(0) = 3
cindex(1) = 5
cindex(2) = 6
cindex(3) = 8
cindex(4) = 10
title(0) = "紧急"
title(1) = "重要"
title(2) = "琐事"
title(3) = "小事"
title(4) = "完结"
Debug.Print targetShtName
Set rst = CreateObject("ADODB.Recordset")
Set sht = Sheets(targetShtName)
firstrow = 1
With sht
rst.CursorLocation = 3
For mode = 0 To 4 Step 1
rst.Open SQL(mode), conn, adOpenKeyset
If rst.Fields.Count > 1 Then
Range(Cells(firstrow + 1, 1), Cells(firstrow + 1, rst.Fields.Count)).Merge
.Cells(firstrow + 1, 1).Value = title(mode)
.Cells(firstrow + 1, 1).RowHeight = 35
.Cells(firstrow + 1, 1).HorizontalAlignment = xlCenter ' 居中
.Cells(firstrow + 1, 1).Interior.ColorIndex = cindex(mode)
.Cells(2 + firstrow, i + 1).ColumnWidth = 10
For i = 0 To rst.Fields.Count - 1 '填写标题
fdname = rst.Fields(i).Name
.Cells(2 + firstrow, i + 1).ColumnWidth = getWidth(fdname)
.Cells(2 + firstrow, i + 1).EntireRow.AutoFit
.Cells(2 + firstrow, i + 1) = fdname
Next i
End If
' 复制选择集数据
Range("A" & (firstrow + 3)).CopyFromRecordset rst
firstrow = firstrow + rst.RecordCount + 4
rst.Close
Next mode
' .Cells.EntireColumn.AutoFit '自动调整列宽
.Cells.WrapText = True
Set rst = Nothing
End With
End Sub
' --------------------------------------------------------------------------------
' 根据字段名获得列宽
' 作者：wishmo@tom.com
' 日期：2017年4月25日
' --------------------------------------------------------------------------------
Function getWidth(fdname)
dim wid as Integer
wid = 10
Select Case fdname
Case "分项任务"
wid = 20
Case "详细说明"
wid = 20
Case "结果描述"
wid = 30
Case "备注"
wid = 15
Case Else
wid = 10
End Select
getWidth = wid
End Function
' --------------------------------------------------------------------------------
' 用来从清单生成紧急、重要、次要、琐事4类清单，督促办理
' 作者：wishmo@tom.com
' 日期：2017年4月25日
' --------------------------------------------------------------------------------
Sub GTD()
Dim conn As Object, rst As Object
Set conn = connect()
Set sht = renewSheet("4象限")
Call divide(conn, "4象限")
conn.Close
Set conn = Nothing
End Sub
