excel表格拆分

夕阳天涯无悔

把sheet1表格按照不同的任务编号拆分成若干个excel表格，命名方式是“任务编号_第一个店铺名称第一个字_ 依次_城市合伙人姓名” 每个生成的excel表格 客单价 这一列累计一下       例如：把压缩包中的sheet1分别生成这两个excel文件。

活在理想的世界

哥已经很久没有来冒泡了。

cjc209

你的里面还有图片也要跟随走 那麻烦 我做不到

cjc209

关键是你的命名太麻烦

cjc209

拆开非常简单 就是要取相应单元格内的值后还要处理

cjc209

这种拆分 代码多得很 就是你的命名方式独特 必须要熟练代码之人方可以解决

cjc209

我有通用性的工作表拆分工具代码 你自己去研究看看能不能解决 命名问题[code]Sub 工作表拆分()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim arr As Variant
    Dim i, s As Integer
    Dim brr()

cjc209

1. Sub 工作表拆分()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr As Variant
   
5.     Dim i, s As Integer
   
6.     Dim brr()
   
7.     Dim wb, wb1 As Workbook
   
8.     Dim d As Object
   
9.     Dim hlrow As Integer, cutcolumn As Integer, cuttype As Integer
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.     Dim sh As Worksheet
    
12.     hlrow = InputBox("请输入标题最末行数：", "拆分表格", "1")
    
13.     bwhs = InputBox("请输入表尾的总行数：", "拆分表格", "0")
    
14.     cutcolumn = InputBox("请输入拆分依据列（第一列是1，第二列是2，以此类推）：", "拆分表格", "1")
    
15.     cuttype = InputBox("请选择拆分类型（拆分到本工作簿是1，拆分为多个独立工作簿是2，拆分为一个工作簿是3）：", "拆分表格", "1")
    
16.     bb = MsgBox("是否去除表尾 是为去除 否为保留表尾", vbYesNo)
    
17. 
    
18.     lastCol = Selection.SpecialCells(xlCellTypeLastCell).Column
    
19.     lastRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
20.     arr = ActiveSheet.Range("a1", ActiveSheet.Cells(lastRow - bwhs, lastCol))
    
21.     For i = hlrow + 1 To UBound(arr)
    
22.         If Not d.exists(arr(i, cutcolumn)) Then
    
23.           If Cells(i, cutcolumn) = "" Then GoTo 3
    
24.             Set d(arr(i, cutcolumn)) = ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2))
    
25.         Else
    
26.             Set d(arr(i, cutcolumn)) = Union(d(arr(i, cutcolumn)), ActiveSheet.Range("a" & i).Resize(1, UBound(arr, 2)))
    
27. 
    
28.         End If
    
29. 3:
    
30.     Next i
    
31.    x = d.keys
    
32. If cuttype = 1 Then
    
33. 
    
34. For k = 0 To d.Count - 1
    
35.          
    
36.          
    
37.             Worksheets.Add after:=Worksheets(Worksheets.Count)
    
38.          
    
39.             ActiveSheet.Name = x(k)
    
40.             ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy ActiveSheet.[a1]
    
41.             d.items()(k).Copy ActiveSheet.Cells(hlrow + 1, 1)
    
42.             If bb = 7 Then
    
43.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
44.             qsh = lastRow - Val(bwhs) + 1
    
45.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
    
46.             Else
    
47.            End If
    
48. Next k
    
49. End If
    
50.   If cuttype = 3 Then
    
51.         Application.SheetsInNewWorkbook = d.Count
    
52.         Set wb1 = Workbooks.Add
    
53.         i = 1
    
54.         For Each k In d.keys
    
55.             wb1.Worksheets(i).Name = k
    
56.            wb1.Worksheets(i).Activate
    
57.              ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy wb1.Worksheets(x(k1)).[a1]
    
58.             d.items()(k1).Copy wb1.Worksheets(x(k1)).Cells(hlrow + 1, 1)
    
59.             If bb = 7 Then
    
60.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
61.             qsh = lastRow - Val(bwhs) + 1
    
62.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
    
63.             Else
    
64.             End If
    
65.             k1 = k1 + 1
    
66.             i = i + 1
    
67.         Next k
    
68.     End If
    
69.    
    
70.     For k = 0 To UBound(x)
    
71.       
    
72.         If cuttype = 2 Then
    
73.             Application.SheetsInNewWorkbook = 1
    
74.             Set wb = Workbooks.Add
    
75.             With wb.Worksheets(1)
    
76.                 ThisWorkbook.Worksheets(1).Rows("1:" & hlrow).Copy .[a1]
    
77.                 d.items()(k).Copy .Cells(hlrow + 1, 1)
    
78.                  If bb = 7 Then
    
79.             zdRow = Selection.SpecialCells(xlCellTypeLastCell).Row
    
80.             qsh = lastRow - Val(bwhs) + 1
    
81.             ThisWorkbook.Worksheets(1).Rows(qsh & ":" & lastRow + 1).Copy ActiveSheet.Cells(zdRow + 1, 1)
    
82.             Else
    
83.             End If
    
84.                 wb.SaveAs Filename:=ThisWorkbook.Path & "" & x(k) & ".xls"
    
85.                 wb.Close
    
86.             End With
    
87.         End If
    
88.     Next k
    
89.     If cuttype = 3 Then
    
90.         wb1.SaveAs Filename:=ThisWorkbook.Path & "" & "拆分数据表.xls"
    
91.         wb1.Close False
    
92.     End If
    
93. 5:
    
94.     Application.DisplayAlerts = True
    
95.     Application.ScreenUpdating = True
    
96.     MsgBox "拆分完毕！"
    
97.    
    
98. End Sub
    

复制代码

abc123281

代码仅供测试参考   至于重命名  没这种说法  如果数据很多又如何命名



拆分表123.rar (220.6 KB, 下载次数: 4)

2018-9-2 01:31 上传

点击文件名下载附件