[已解决]按指定列拆分Excel，数据贴到N个表里

nonfish

前两天发了一个“按一列拆分Excel”的问题，没有特别被完美的解答，最近刚从网上搜来一段代码刚好满足我的需求。
现在分享给大家。
其中代码里可以通过a(i, 1)中数字1，可以改变想要依据某列拆分当前Excel。
我是VBA小白，还想请教下老师们，如果我想在运行代码前，通过跳出的对话框来确定这想要按某列分组，怎么改？？
比如：跳出对话框：“请输入想按某列分组：——”，我通过在对话框里填写数字或者列标来实现对分列依据的修改！！！

另外，再进一步优化代码，如果各列字段名在数据原表的第2行，怎么改代码还能实现同样的效果？？

这是原帖：
http://www.excelpx.com/thread-199725-1-1.html

这是找到的代码：

1. Sub chaifen()
   
2. Dim a, b(), d
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Application.ScreenUpdating = False
   
5. a = Sheet1.UsedRange
   
6. For i = 2 To UBound(a)
   
7.    If Not d.exists(a(i, 1)) Then
   
8.       da(i, 1)) = i
   
9.    Else
   
10.       d(a(i, 1)) = d(a(i, 1) & "," & i
    
11.    End If
    
12. Next
    
13. k = d.keys
    
14. p = ThisWorkbook.Path & ""
    
15. For i = 0 To d.Count - 1
    
16.    x = Split(d(k(i)), ",")
    
17.    ReDim b(1 To UBound(x) + 2, 1 To UBound(a, 2))
    
18.    For j = 1 To UBound(a, 2)
    
19.       b(1, j) = a(1, j)
    
20.    Next
    
21.    m = 1
    
22.    For l = 0 To UBound(x)
    
23.       m = m + 1
    
24.       For j = 1 To UBound(a, 2)
    
25.          b(m, j) = a(x(l), j)
    
26.       Next
    
27.    Next
    
28.    With Workbooks.Add
    
29.       .Sheets(1).[a1].Resize(m, UBound(a, 2)) = b
    
30.       .SaveAs Filename:=p & k(i) & ".xls"
    
31.       .Close
    
32.     End With
    
33. Next
    
34. Application.ScreenUpdating = True
    
35. End Sub

复制代码

最佳答案

月排行榜 / 总排行榜

9lee

2011-9-30 16:50

回复 nonfish 的帖子

数据表拆分.rar (13.38 KB, 下载次数: 290)

2011-9-30 16:49 上传

点击文件名下载附件

跳转到最佳答案楼层

nonfish

前面回复的都评分，加完为止，麻烦各位老师了！！！

nonfish

快6点了，今天回老家，估计没时间评分了，有修改好的，假期回来定兑现。

感谢大家了！！！

9lee

回复 nonfish 的帖子

数据表拆分.rar (13.38 KB, 下载次数: 290)

2011-9-30 16:49 上传

点击文件名下载附件

上清宫主

这个论坛中有很多拆分的代码都很优秀，slq、筛选、字典……找找吧

wjlei

Sub 将数据按条件分类导出() '将当前单元格所在的列的数据按筛选条件分别复制到新的工作表中
'使用宏前要先点选数据所在列的任意一个单元格，数据列的头一行做标题使用
Dim XSH As Worksheet, TSH As Worksheet
Dim TRan As Range
Dim i As Integer, FN As Integer
Dim PD As Boolean
Dim Down As VbMsgBoxResult
Down = MsgBox("当前单元格应该在数据区域中" & vbCrLf & "并且按当前单元格所在列筛选" & vbCrLf & "       是否继续？", vbYesNo, "提示")
If Down = vbNo Then Exit Sub
Set XSH = ActiveSheet
PD = XSH.AutoFilterMode
If PD = False Then XSH.UsedRange.AutoFilter
Set TRan = ActiveCell.CurrentRegion
FN = ActiveCell.Column - TRan.Item(1).Column + 1
For i = 2 To TRan.Rows.Count
    If WorksheetFunction.CountIf(Range(TRan.Item(1).Cells(1, FN), TRan.Item(1).Cells(i, FN)), TRan.Item(1).Cells(i, FN)) = 1 Then
        Set TSH = Sheets.Add(after:=ActiveSheet)
        TSH.Name = TRan.Item(1).Cells(i, FN)
        XSH.Select
        XSH.UsedRange.AutoFilter field:=FN, Criteria1:=TRan.Item(1).Cells(i, FN)
        TRan.SpecialCells(xlCellTypeVisible).Copy
        TSH.Select
        TSH.Paste
        XSH.Select
    End If
Next
If PD = False Then XSH.UsedRange.AutoFilter
End Sub

nonfish

回复 9lee 的帖子

能否帮忙调整一下输出表的格式和原表一样？

输出表数据都是常规格式，遇到身份证号等较长编号时，显示会有问题~~~~{:021:}

9lee

回复 nonfish 的帖子

在最后加了二句代码：（下面的第2和第5句）

1. Next
   
2. rng.Rows(2).Copy
   
3. With Workbooks.Add
   
4. .Sheets(1).[a1].Resize(m, UBound(c, 2)) = b
   
5. .Sheets(1).[a1].Resize(m, UBound(c, 2)).PasteSpecial Paste:=xlPasteFormats
   
6. .SaveAs Filename:=p & k(i) & ".xls"
   
7. .Close
   
8. End With
   
9. Next
   
10. MsgBox "拆分完毕！"
    
11. Application.ScreenUpdating = True
    
12. End Sub

复制代码

nonfish

回复 9lee 的帖子

我试了一下，居中字体基本上都OK了。
把第4句和第5句换下位置，日期格式也OK了，

但是文本格式的超长数字编码还是不行。。。

9lee

回复 nonfish 的帖子

方法不是最好，请再问一下其他同学：

1. 
   

复制代码

1. Sub chaifen()
   
2. Dim a, b(), d, icol, c, rng, l
   
3. On Error Resume Next
   
4. a = Columns("c")
   
5. Set rng = Sheet1.UsedRange
   
6. 1000:
   
7. icol = Application.InputBox("请输入需要拆分的列号：", , "请输入A, B, C……", , , , 2)
   
8. If icol = "请输入A, B, C……" Then
   
9. MsgBox "没有输入拆分列号！": GoTo 1000
   
10. ElseIf icol = False Then
    
11. Exit Sub
    
12. 
    
13. ElseIf Cells(1, icol).Column > rng.End(xlToRight).Column Then
    
14. MsgBox "输入的列号无效或已超过有效范围！": GoTo 1000
    
15. End If
    
16. Application.ScreenUpdating = False
    
17. 
    
18. a = Intersect(rng, Columns(icol))
    
19. c = rng
    
20. Set d = CreateObject("scripting.dictionary")
    
21. For i = 2 To UBound(a)
    
22. If Not d.exists(a(i, 1)) Then
    
23. d(a(i, 1)) = i
    
24. Else
    
25. d(a(i, 1)) = d(a(i, 1)) & "," & i
    
26. End If
    
27. Next i
    
28. k = d.keys
    
29. p = ThisWorkbook.Path & ""
    
30. For i = 0 To d.Count - 1
    
31. x = Split(d(k(i)), ",")
    
32. ReDim b(1 To UBound(x) + 2, 1 To UBound(c, 2))
    
33. For j = 1 To UBound(c, 2)
    
34. b(1, j) = c(1, j)
    
35. Next j
    
36. m = 1
    
37. For l = 0 To UBound(x)
    
38. m = m + 1
    
39. For j = 1 To UBound(c, 2)
    
40. b(m, j) = c(x(l), j)
    
41. Next j
    
42. Next l
    
43. For j = 1 To UBound(c, 2)
    
44. If VBA.IsNumeric(brr(2, j)) And Len(brr(2, j)) >= 12 Then ss = j
    
45. Next j
    
46. rng.Rows(2).Copy
    
47. With Workbooks.Add
    
48. .Sheets(1).[a1].Resize(m, UBound(c, 2)).PasteSpecial Paste:=xlPasteFormats
    
49. .Sheets(1).Columns(ss).NumberFormatLocal = "@"
    
50. .Sheets(1).[a1].Resize(m, UBound(c, 2)) = b
    
51. .SaveAs Filename:=p & k(i) & ".xls"
    
52. .Close
    
53. End With
    
54. Next i
    
55. MsgBox "拆分完毕！"
    
56. Application.ScreenUpdating = True
    
57. End Sub

复制代码