按列拆分工作簿

哈哈哈。

我想对J列报错省按照省名进行拆分成各个工作簿，簿名就是省名，该如何实现？

唐朝123

没法帮你：
1-没附件；
2-省份报错了还要以省份名字命名？
3-新建工作簿还是工作表？

lsc900707

按列拆分工作簿的实例论坛很多呀。
传个图片就要别人写代码？

boyayes

实在对不住，前天本菜鸟小试射手，刚好写了这么一段代码。现成的。分享给你用一下，记着，我要鲜花。先发代码，也会发出附件。

1. Sub 拆分总表()
   
2.     Sheets(1).Select
   
3.     Ro = [A65536].End(3).Row '根据第A列提取最大行数
   
4.     Co = [XFD1].End(1).Column '根据第1行提取最大列数
   
5.     Dim i As Integer, sht As Worksheet
   
6.     m = InputBox("按第几列拆分？" & Chr(10) & Chr(10) & "列序数范围：1 至 " & Co & "")
   
7.     '退出机制
   
8.     If Not IsNumeric(m) Then
   
9.         MsgBox "你输入的不是数字！"
   
10.         Exit Sub
    
11.     ElseIf m * 1 > Co Then
    
12.         MsgBox "超出了数据的列数！"
    
13.         Exit Sub
    
14.     End If
    
15.     '删除分表
    
16.     Call 删除分表
    
17.     '创建新表
    
18.     For i = 2 To Ro
    
19.         k = 0
    
20.         For Each sht In Sheets
    
21.             If sht.Name = Sheets(1).Cells(i, m * 1) Then
    
22.                 k = 1
    
23.                 Exit For
    
24.             End If
    
25.         Next
    
26.         If k = 0 Then
    
27.             Sheets.Add(after:=Sheets(Sheets.Count)).Name = Sheets(1).Cells(i, m * 1)
    
28.         End If
    
29.     Next
    
30.     '拷贝数据
    
31.     For i = 2 To Sheets.Count
    
32.         Sheets(1).[A1].Resize(Ro, Co).AutoFilter Field:=m, Criteria1:=Sheets(i).Name
    
33.         Sheets(1).[A1].Resize(Ro, Co).Copy Sheets(i).[A1]
    
34.     Next
    
35.     Sheets(1).[A1].Resize(Ro, Co).AutoFilter
    
36.     Sheets(1).Select
    
37.     MsgBox "操作完毕！"
    
38. End Sub
    
39. 
    
40. Sub 删除分表()
    
41.     Dim sht As Worksheet
    
42.     Application.DisplayAlerts = False
    
43.     For Each sht In Sheets
    
44.         If sht.Name <> Sheets(1).Name Then
    
45.             sht.Delete
    
46.         End If
    
47.     Next
    
48.     Application.DisplayAlerts = True
    
49. End Sub

复制代码

lsc900707

boyayes 发表于 2019-3-15 12:46
实在对不住，前天本菜鸟小试射手，刚好写了这么一段代码。现成的。分享给你用一下，记着，我要鲜花。先发代 ...

这是拆分成工作表的代码。

boyayes

lsc900707 发表于 2019-3-15 12:52
这是拆分成工作表的代码。

噢，原来是要拆分是工作簿。那重写代码也行，其实在我这段代码的基础上，再加几行代码也可以做到，就是把拆分后的分表，除第一个工作表外，其它的工作表全都COPY一下，并按表的名字给工作簿命名就可以了。

lrh788

boyayes 发表于 2019-3-15 13:00
噢，原来是要拆分是工作簿。那重写代码也行，其实在我这段代码的基础上，再加几行代码也可以做到，就是把 ...

请老师写个拆分为工作簿的代码，并设定保存到指定的文件夹中

boyayes

lrh788 发表于 2020-6-19 19:59
请老师写个拆分为工作簿的代码，并设定保存到指定的文件夹中

现在很少上来了

yufan

没有附件原数据行数未知，如出现“下标越界”错误可适当增加 br 数组行数：