楼主
kevinchengcw |
Q: 如何用vba代码提取指定列内容生成总表及分项表？
A: 实现代码如下：- Sub test()
- Dim Rule, Arr, Arrt, Result, N&, I&, T&, A&, Dic As Object, Str$
- Rule = Split("CWB_CWB_NO，CWB_SVCE_TYP_CD，CWB_TOTAL_WT_KG，CWB_TOTAL_VOL_WT_UT_KG，CWBTR_FRCHRG_DUTY_BILL_TYP，CWBDU_FRCHRG_DUTY_BILL_TYP，CCHG_TR_CURR_CD，CCHG_TR_AMT，MAWB_NO，CWB_DST_STA_CD", "，") '拆分生成指定列数组
- Set Dic = CreateObject("scripting.dictionary") '创建字典项目
- For N = LBound(Rule) To UBound(Rule) '将列标题装入字典中以代替循环判断
- Dic(Rule(N)) = ""
- Next N
- With ActiveSheet
- Arr = .UsedRange.Value '提取活动工作表使用区数据
- End With
- ReDim Result(LBound(Arr) To UBound(Arr), 1 To UBound(Rule) + 1) '根据提取到的数据定义结果数组
- T = 0: A = 0 '初始化数组列号记录及拆分列号记录
- For N = LBound(Arr, 2) To UBound(Arr, 2) '循环源数据数组列
- Str = Trim(Arr(1, N)) '取得列标题
- If Dic.exists(Str) Then '如果存在该字典项,则
- T = T + 1 '列号加1
- For I = LBound(Arr) To UBound(Arr) '将源数据当前列内容写入对应的结果数组列中
- Result(I, T) = Arr(I, N)
- Next I
- If Str = "CWB_DST_STA_CD" Then A = T '如果是标题是拆分列的标题,则记录下在结果数组中的列号
- End If
- Next N
- Dic.RemoveAll '清空字典项目
- T = Application.SheetsInNewWorkbook '提取新建工作簿中的工作表数量当前值
- Application.SheetsInNewWorkbook = 1 '设定新建工作簿中工作表数量为1
- With Workbooks.Add '添加新工作簿
- Application.SheetsInNewWorkbook = T '恢复原新建工作簿中的工作表数量值
- With .ActiveSheet '向新添加的工作簿的活动工作表写入数据
- .[a1].Resize(UBound(Result), UBound(Result, 2)).Value = Result '写入结果数组数据
- .Columns.AutoFit '列宽自适应
- .Name = "Total" '表名命名为Total
- End With
- If A > 0 Then '如果存在需拆分的关键列,则
- For N = LBound(Result) + 1 To UBound(Result) '循环结果数组中除标题外的各行
- Str = Trim(Result(N, A)) '提取当前行对应的关键列值
- If Dic.exists(Str) Then '如果已存在该字典项,则
- Arr = Dic(Str) '提取出字典ITEM对应的数组
- Arr(Arr(0) + 1) = N '数组第一位记录总记录数的下一单元的值记录当前行号
- Arr(0) = Arr(0) + 1 '数组总记录数加1
- Else '不存在该字典项,则
- ReDim Arr(0 To UBound(Result)) '重定义比结果数组总行数多1项的一维数组,数组第一项用来记录总记录数
- Arr(0) = 1 '总记录数初始为1
- Arr(1) = N '记录下对应的行号
- End If
- Dic(Str) = Arr '数组写回字典对应项
- Next N
- Arr = Dic.keys '提取字典keys
- For N = LBound(Arr) To UBound(Arr) '循环各个key
- With Worksheets.Add(, Worksheets(Worksheets.Count)) '在全部工作表后添加新工作表
- .Name = Arr(N) '依key值命名
- Rule = Dic(Arr(N)) '提取储存行号的数组
- ReDim Arrt(1 To Rule(0) + 1, LBound(Result, 2) To UBound(Result, 2)) '重定义保存结果的数组,行数加1用来写标题行
- For T = LBound(Result, 2) To UBound(Result, 2) '循环写入标题行
- Arrt(1, T) = Result(1, T)
- Next T
- For I = 1 To Rule(0) '循环储存行号的数组中的有效项
- For T = LBound(Result, 2) To UBound(Result, 2) '提取对应行的数据到结果数组中
- Arrt(I + 1, T) = Result(Rule(I), T)
- Next T
- Next I
- .[a1].Resize(UBound(Arrt), UBound(Arrt, 2)).Value = Arrt '向添加的分项工作表中写入数据
- .Columns.AutoFit '列宽自适应
- End With
- Next N
- End If
- .SaveAs ThisWorkbook.Path & "\Result", ThisWorkbook.FileFormat '将工作簿保存为当前工作簿目录下,命名为Result,文件格式与当前工作簿相同
- .Close False '关闭工作簿
- End With
- Set Dic = Nothing '清空字典项目
- End Sub
详见附件及素材源帖.
 范例.rar
|
