智能识别字段拆分总表

楼主水星钓鱼	功能说明：如果要根据拆分的字段是日期、数值格式则不拆分，因为没有拆分意义；如果选择了多个字段，则不拆分；可以通过选择要拆分的字段所在的一整列或者所在的项目单元格来智能识别要拆分的字段。动画如下：附件如下：根据某个字段的不重复项目拆分总表.rar 代码如下 Option Explicit Public sRng As String Public sSqlRng As String Public sFieldName As String Private Sub CommandButton1_Click() On Error Resume Next Dim oRecrodset Dim arr Dim sConStr As String Dim sSql As String Dim oWk As Worksheet Dim i As Integer Dim j As Integer Dim sfn As String Application.DisplayAlerts = False For Each oWk In Application.Worksheets If oWk.Name <> Me.Name Then oWk.Delete End If Next Application.DisplayAlerts = True sFieldName = "" Call xyf If Err.Number = 424 Then Exit Sub End If sConStr = "Provider='Microsoft.Jet.OLEDB.4.0';Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=YES'" sSql = "select distinct " & sFieldName & " from [" & sSqlRng & "] where Not IsNull(" & sFieldName & ")" Set oRecrodset = CreateObject("ADODB.Recordset") With oRecrodset .Open sSql, sConStr arr = .getrows .Close Application.Evaluate(sRng).Copy For i = 0 To UBound(arr, 2) If Len(arr(0, i)) Then On Error GoTo solution sSql = "select * from [" & sSqlRng & "] where " & sFieldName & "='" & arr(0, i) & "'" .Open sSql, sConStr Set oWk = ThisWorkbook.Worksheets.Add(After:=ActiveSheet) oWk.Name = arr(0, i) For j = 1 To .Fields.Count oWk.Cells(1, j) = .Fields(j - 1).Name Next oWk.Cells(2, 1).CopyFromRecordset oRecrodset oWk.[a1].CurrentRegion.PasteSpecial xlPasteFormats oWk.Columns.AutoFit .Close End If Next Application.CutCopyMode = False End With Set oRecrodset = Nothing Exit Sub solution: MsgBox "你选择的字段不适合用来拆分总表，请重新选择!" Application.CutCopyMode = False End Sub Sub xyf() Dim oRng As Range Set oRng = Application.InputBox(prompt:="请你选择要根据哪个字段拆分销售汇总表?", Title:="拆分总表", Type:=8) sRng = oRng.CurrentRegion.Address(False, False, xlA1, True) sSqlRng = Mid(Replace(sRng, "!", "$", , 1), InStr(1, sRng, "]") + 1) If oRng.Columns.Count = 1 Then sFieldName = "[" & oRng.End(xlUp).Value & "]" End If Set oRng = Nothing End Sub 补充内容 (2014-1-11 07:09): 请使用帖子右下角的评分功能给这个帖子评分补充内容 (2014-1-11 07:24): 请使用帖子右下角的评分功能给这个帖子评分
2楼 Rongson_Chart	好东西~~~~！
3楼 vigossdawn	版主这代码都是自己写的啊 VBA学起来怎么样书都积压好久了还没看
4楼杨开科	收藏备用。
5楼 NatGeo	下载学习。
6楼水星钓鱼	VBA还是要多靠实践，看书不实践收效甚微，主要是知识点太多了。
7楼 sxtony	好东西
8楼 sunman	收了，正需要呢
9楼贝心心	真是太有用了，经常手工拆分表格的人伤不起啊伤不起
10楼 Andy920	有没有类似的宏，我每个月都要做财务费用分析，从系统导出的数据要分配到各个部门，很烦的。看到这个按字段分配很好，有没有类似的宏，可以解决的。
11楼諸星曜	感谢分享学习
12楼 hhy0206	太强大了。
13楼 sodapop66	请问下 lz，为何我按照gif的图操作，无论选择哪个字段进行拆分（地区、品名等）都不能出现gif中的拆分结果，总会提示“你选择的字段不适合用来拆分总表，请重新选择！”呢？ ps 我的excel是2003版本的
14楼何-TT丫	为什么一直显示“你选择的字段不适合拆分总表呢：求解啊
15楼 amulee	不错，挺好
16楼许十一	这代码复制了放哪啊
17楼靖_某khaki	太厉害了，回去好好研究一下做法
18楼钦钦糖	为什么我下载了，而且根据动画提示操作了，但是说我所选择的字段不适合拆分总表，请重新选择
19楼淼淼爹	楼主不地道，放个代码纯粹让人馋的，你这代码不行，认得位置也不对，无法改宏，直接复制按钮和代码过去了还不能直接用，唯一值得称赞的就是思路了，回去我自己弄一个
20楼 Erica_Zhang01	好！赞一个
21楼 cyzww411	这个代码怎么使用呢，还请版主赐教呀
22楼婆婆	好东西**
23楼 hendry	好东西，可以问个问题么？ If Err.Number = 424 Then Exit Sub End If 这个命令起到什么作用？
24楼 hl_irnt	07版的不行啊
25楼じ☆潴の︵ゞ
26楼水星钓鱼	请重新下载顶楼的附件，已经修改过了。
27楼水星钓鱼	请重新下载顶楼的附件，已经修改了附件。
28楼水星钓鱼	已经修改了顶楼的附件，请重新下载。
29楼水星钓鱼	按“取消”则退出。
30楼 cyzww411	这段代码如何使用呀，求教各位大侠
31楼 246129162	你好，这个代码不加那个按钮的话直接alt+F11 之后为啥运行出现了“选择拆分字段”之后就没有任何反应了，把同一组数据复制到你模板中按那个黄色按钮就可以拆分。我是漏了什么步骤吗？
32楼差不多老窝	求教如何使用？代码从哪设置
33楼何-TT丫	为什么我还是用不到呢,好纠结啊
34楼何-TT丫	我点击了拆分销售汇总表没反应啊
35楼泽洛	楼主好
36楼泽洛	谢谢分享~~~~
37楼水星钓鱼	请把你的附件上传上来
38楼泽洛	我已经搞定了是我把代码拷到加载宏而上面的应引用是thisworkbook 改成activeworkbook就OK了** 谢谢
39楼水星钓鱼	OK，欢迎常来，看你的回复你的水平也挺高的。
40楼泽洛	我入门级的请问如果想要也可以对数值和日期进行拆分，要怎么修改啊？？谢谢
41楼水星钓鱼	我认为那样拆分没有意义，所以就没有写这方面的代码了。
42楼 lrlxxqxa	很实用的代码
43楼 limfreedom	好强**！
44楼木_阿佐	VBA强大呀！
45楼 c豆腐小丸子c	下载的附件，运行就可以拆分，我用到其他表里就出错：编译错误：无效使用 Me 关键字。请不吝赐教，谢谢。劳务派遣招聘简历.zip
46楼过的什么日子	还是不会用
47楼静Tiffany	我按照代码复制输入，为什么按了按钮后没有反应呢？
48楼静Tiffany	楼主,请赐教哇~!
49楼 hylees	学习
50楼苏李_斌	请问这如何使用呢，我选择了所选列之后就没有动静了~
51楼苏李_斌	数据最多可以有多少行呢？我60多万显示不能拆分
52楼 yapieya	真厉害，就是不知道复制下来要怎么用？
53楼 yapieya	再次感叹，太强大了
54楼 pluto	如何把代码放到excel中，才能使用呢？
55楼 chen198191	找这个找很久了
56楼 szzs_1	我跟你的情况是一样的有解决方法么/
57楼离离原上草	不懂VBA的只能模仿用，非常感谢，膜拜
58楼 id_lck	看着非常实用,先收着
59楼 wo的閣閣窩	太好了
60楼 weikang2516	收藏备用，肯定用得到
61楼 chanel1115	楼主威武，下载了，谢谢~~~
62楼 In-coming	谢谢楼主，好东西
63楼飚在路上	好东西，要学习下。
64楼崔婧婧	太棒了！已经在用！拜谢楼主！
65楼芹泽多摩雄	好东西好东西赞赞赞
66楼 jily_78	太牛了，下载备用
67楼秋天的无花果	收藏备用。
68楼 JIANG_YUMMY	太棒了~~~~~
69楼 JIANG_YUMMY	楼主，能否做个动画教程，把这个VBA代码如何放进我们的EXCEL，多谢了，这个真的太棒太有用了，只是不知道自已怎么用呢？多谢楼主了，感激不尽
70楼 weikang2516	太好了，谢谢版主
71楼 sina-8888	谢谢楼主分享
72楼 cyy1905	太感谢版主了，这个非常实用，且用途比较广
73楼雙子座_黎佳	太有用了，收藏。
74楼 liujinsea	没看懂
75楼 totoby	收藏学习
76楼成就滋味	henb很棒啊，比用透视表解决更有效率哈
77楼 Milanmacelo	这个个很有用啊
78楼麦秋	真是太有用了，经常手工拆分表格的人伤不起啊伤不起
79楼 just_myself	收了，实用性很强。我现在碰到的拆分表格用不了这样的代码，不知道哪位能帮我解决下？
80楼 just_myself	我是新人，谁能否帮我按分类进行分字段呢？销售.zip
81楼水星钓鱼	功能说明：如果要根据拆分的字段是日期、数值格式则不拆分，因为没有拆分意义；如果选择了多个字段，则不拆分；可以通过选择要拆分的字段所在的一整列或者所在的项目单元格来智能识别要拆分的字段。动画如下：附件如下：根据某个字段的不重复项目拆分总表.rar 代码如下 Option Explicit Public sRng As String Public sSqlRng As String Public sFieldName As String Private Sub CommandButton1_Click() On Error Resume Next Dim oRecrodset Dim arr Dim sConStr As String Dim sSql As String Dim oWk As Worksheet Dim i As Integer Dim j As Integer Dim sfn As String Application.DisplayAlerts = False For Each oWk In Application.Worksheets If oWk.Name <> Me.Name Then oWk.Delete End If Next Application.DisplayAlerts = True sFieldName = "" Call xyf If Err.Number = 424 Then Exit Sub End If sConStr = "Provider='Microsoft.Jet.OLEDB.4.0';Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 8.0;HDR=YES'" sSql = "select distinct " & sFieldName & " from [" & sSqlRng & "] where Not IsNull(" & sFieldName & ")" Set oRecrodset = CreateObject("ADODB.Recordset") With oRecrodset .Open sSql, sConStr arr = .getrows .Close Application.Evaluate(sRng).Copy For i = 0 To UBound(arr, 2) If Len(arr(0, i)) Then On Error GoTo solution sSql = "select * from [" & sSqlRng & "] where " & sFieldName & "='" & arr(0, i) & "'" .Open sSql, sConStr Set oWk = ThisWorkbook.Worksheets.Add(After:=ActiveSheet) oWk.Name = arr(0, i) For j = 1 To .Fields.Count oWk.Cells(1, j) = .Fields(j - 1).Name Next oWk.Cells(2, 1).CopyFromRecordset oRecrodset oWk.[a1].CurrentRegion.PasteSpecial xlPasteFormats oWk.Columns.AutoFit .Close End If Next Application.CutCopyMode = False End With Set oRecrodset = Nothing Exit Sub solution: MsgBox "你选择的字段不适合用来拆分总表，请重新选择!" Application.CutCopyMode = False End Sub Sub xyf() Dim oRng As Range Set oRng = Application.InputBox(prompt:="请你选择要根据哪个字段拆分销售汇总表?", Title:="拆分总表", Type:=8) sRng = oRng.CurrentRegion.Address(False, False, xlA1, True) sSqlRng = Mid(Replace(sRng, "!", "$", , 1), InStr(1, sRng, "]") + 1) If oRng.Columns.Count = 1 Then sFieldName = "[" & oRng.End(xlUp).Value & "]" End If Set oRng = Nothing End Sub 补充内容 (2014-1-11 07:09): 请使用帖子右下角的评分功能给这个帖子评分补充内容 (2014-1-11 07:24): 请使用帖子右下角的评分功能给这个帖子评分
82楼 Rongson_Chart	好东西~~~~！
83楼 vigossdawn	版主这代码都是自己写的啊 VBA学起来怎么样书都积压好久了还没看
84楼杨开科	收藏备用。
85楼 NatGeo	下载学习。
86楼水星钓鱼	VBA还是要多靠实践，看书不实践收效甚微，主要是知识点太多了。
87楼 sxtony	好东西
88楼 sunman	收了，正需要呢
89楼贝心心	真是太有用了，经常手工拆分表格的人伤不起啊伤不起
90楼 Andy920	有没有类似的宏，我每个月都要做财务费用分析，从系统导出的数据要分配到各个部门，很烦的。看到这个按字段分配很好，有没有类似的宏，可以解决的。
91楼 ddstudio	下载学习好东西
92楼晨夕早	代码复制了放哪里啊
93楼 mywebid	很实用，收藏了。
94楼 hellojiakun	收藏了
95楼 AKA葱头	新人下载来学习的··
96楼第二杯半价	很好的代码啊
97楼 wsms	来学习下
98楼 yirenxiangtao
99楼穿梭	为什么我的电脑运行起来就是 “你选择的字段不适合拆分总表”，Office2007/2010下都一样，只是按照下载的附件进行操作都这样？
100楼时央vina	好东西！赞一个！
101楼 ponesme	我觉得有些功能是需要VBA来实现的，但看着满满的代码，我学的动力都木有了，呜呜
102楼加百列	哪位大拿帮忙修改为创建新宏就能使用的，只能当模板用啊
103楼 lplcs	有谁有宏的好的教材推荐码？谢谢
104楼 pkpkyb	有用
105楼 sina-8888	这个好，登门谢过
106楼 icenotcool
107楼白玮	不错
108楼假面悲哀	弱弱的问一句下载完了那个黄色按钮为什么点不了呢。
109楼水星钓鱼	要启用宏
110楼假面悲哀	谢谢
111楼 xunpeng3721	太强了，厉害啊
112楼小石头也快乐	碉堡了楼主v5
113楼『青青』	x学习了
114楼 zgz200	看下感觉像是挺好啊。学VBA学不来好烦恼。
115楼 dengfan	谢了！强！
116楼六尺冰纹	非常实用的功能
117楼 alexdg
118楼 iceicerain	收藏备用！
119楼亡者天下	谢谢分享，学习了！
120楼 crb2647	收藏备用
121楼 datouda	给力！做过用advancedfilter拆分的。
122楼大唐暴力诗人	好东西，要分享！
123楼荒火秋叹	如何植入这个代码呢？
124楼 yyw1940	实用~~
125楼『青青』	+5
126楼 335081548	谢谢分享
127楼 cola	，标记，学习
128楼小气包	这就是我要的功能，可是代码是要放哪里的啊？可以说下小白看得懂的步骤吗？万分感谢！
129楼 yytax2010	谢谢分享！