I. 设计构想
无论是在哪个领域,也不分新人还是老手,工作中可能总会有些常用名词需要记忆总结;对于这种相对低频度,又对分类归纳排序等有一定要求的工作,Excel 是一个合适的实现方式。
Excel 确实也提供了“分类汇总”这样智能的一键生成工具,但是其效果对于查看和打印稍显不便,也出现了一些多余的名称和数字:
这时自然想到 Excel 中另一个常用的功能--“数据透视表”,样式美观分类清晰;可问题是,对于生成后的透视表,只能显示统计数字而非原始文字,表头也不能改回原来的名称。
如果能想数据透视表那样分类显示,又能正常显示文字和表头,那便是极好的了~ 好在结合一些简单的 VBA,就可以到达这样的目的。
II. 实现方式
按如下步骤实现我们的想法:
- 建立基础数据源表格,以后也可在此表内不断更新单词
- 点击按钮控件,用 VBA 自动生成相应透视表
- 将透视表自动复制到一张工作表中,该表就是普通的可编辑数据了
- 识别新表格中的有用数据,从源表格中查找对应的原始文字
- 完成替换和格式整理
III. 表格初加工
首先来建立的,是一个 scopes_sheet
工作表,用来枚举单词所归纳到的领域,并在源表中实现下拉选择操作:
然后建立源表 source_sheet
,填充“名称、全称、别称、解释”几列数据,并将“领域”一列的数据验证设为从 scopes_sheet
中枚举的序列:
插入两个按钮控件,指定对应的宏:
然后进入开发工具中的 VBA 开发环境,开始编写代码(for mac 上会有bug,本例基于 Excel 2016 for Windows 开发)
IV. VBA知识点
异常捕获
和其他语言中的 try...catch
相似的是,VBA 中的错误捕获是这样的:
On Error GoTo errfailback
'正常代码的 try 语句
errfailback:
'处理错误的 catch 语句
If Err.Number <> 0 Then
Debug.Print (Err.Description)
End If
Resume errresume
errresume:
'总会执行的善后 finally 语句复制代码
取得表格中行列最大范围的几种方法:
Dim lastCol As Long, lastRow As Long
lastCol = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Column
lastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).row复制代码
Dim name As String, row As Integer
For row = 2 To Sheet1.UsedRange.Rows.Count
name = Sheet1.Cells(row, 1).Value
Next row复制代码
创建数据透视表
Dim pvtTable As PivotTable
Set pvtTable = Sheet1.PivotTableWizard
'specify row & col
pvtTable.AddFields _
RowFields:=Array(COL_FIRST, COL_NAME), _
ColumnFields:="Data"
'sepcify data fields
Dim dfName As String, pvtField As PivotField
For i = 2 To lastCol
dfName = Sheet1.Cells(1, i).Value
Set pvtField = pvtTable.PivotFields(dfName)
pvtField.Orientation = xlDataField
pvtField.Function = xlCount
Next i复制代码
拷贝表格
sheet.Range(Cells(1, 1), Cells(lastRow, lastCol)).Select
Selection.Copy
Dim ShtName As String
ShtName = Replace(PvtName, "pvt_", "sheet_")
Sheets.Add.Select
ActiveSheet.name = ShtName
Cells(1, 1).Select
Selection.PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
Sheets(ShtName).Select
ActiveSheet.Move after:=Sheets(Sheets.Count)复制代码
提取汉字的首字母
Function toPinyin(p As String) As String
Dim i As Long
i = Asc(p)
Select Case i
Case -20319 To -20284: toPinyin = "A"
Case -20283 To -19776: toPinyin = "B"
Case -19775 To -19219: toPinyin = "C"
Case -19218 To -18711: toPinyin = "D"
Case -18710 To -18527: toPinyin = "E"
Case -18526 To -18240: toPinyin = "F"
Case -18239 To -17923: toPinyin = "G"
Case -17922 To -17418: toPinyin = "H"
Case -17417 To -16475: toPinyin = "J"
Case -16474 To -16213: toPinyin = "K"
Case -16212 To -15641: toPinyin = "L"
Case -15640 To -15166: toPinyin = "M"
Case -15165 To -14923: toPinyin = "N"
Case -14922 To -14915: toPinyin = "O"
Case -14914 To -14631: toPinyin = "P"
Case -14630 To -14150: toPinyin = "Q"
Case -14149 To -14091: toPinyin = "R"
Case -14090 To -13319: toPinyin = "S"
Case -13318 To -12839: toPinyin = "T"
Case -12838 To -12557: toPinyin = "W"
Case -12556 To -11848: toPinyin = "X"
Case -11847 To -11056: toPinyin = "Y"
Case -11055 To -2050: toPinyin = "Z"
Case Else: toPinyin = p
End Select
End Function复制代码
自动换行并调整行高
Columns(3).ColumnWidth = 20
Columns(lastCol).ColumnWidth = 40
Range(Cells(1, 1), Cells(lastRow, lastCol)).Rows.WrapText = True复制代码
设置打印区域和缩放
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = False
End With复制代码
用SQL查询工作表
这个可以说是 Excel VBA 里最实用的功能了,不用外部数据源,直接查询工作表:
Dim cn As ADODB.Connection
Dim rs As ADODB.recordSet
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
Dim sql As String
sql = "SELECT * FROM [source_sheet$] WHERE [" & COL_NAME & "] = '" & theName & "';"
rs.Open sql, cn
...
Cells(r, c).Value = rs.Fields(theField).Value
...
cn.Close
Set cn = Nothing
Set rs = Nothing复制代码
V. 完整代码
https://bitbucket.org/tonylua/useful_words_for_web
注意事项等可参考以上链接中的说明
VI. 参考资料
- baike.baidu.com/item/数据透视表/…
- msdn.microsoft.com/zh-cn/libra…
- jingyan.baidu.com/article/63a…
- stackoverflow.com/questions/5…
- stackoverflow.com/questions/2…
- software-solutions-online.com/excel-vba-w…
- www.exceltip.net/thread-3949…
- stackoverflow.com/questions/1…
- bbs.youkuaiyun.com/topics/6013…
- www.w3school.com.cn/ado/ado_ref…
- stackoverflow.com/questions/3…
- zhidao.baidu.com/question/31…
- msdn.microsoft.com/en-us/libra…
- www.ozgrid.com/forum/forum…
- blog.163.com/ycy_sdfc/bl…
- blog.youkuaiyun.com/iamlaosong/…
- www.experts-exchange.com/questions/2…