[已解决]编辑拆分工作表拆分vba

独奏 · 发表于 2014-2-24 17:34

Sub test()
Dim arr, brr(), d, i, n, x, y, z
Set d = CreateObject("scripting.dictionary")
arr = Sheets("总表").Range("a3:o" & Range("a65536").End(xlUp).Row)
ar = Sheets("总表").Range("a1:k5")
For i = 4 To UBound(arr)
If Not d.exists(arr(i, 3)) Then
d(arr(i, 3)) = ""
For n = 4 To UBound(arr)
If arr(n, 3) = arr(i, 3) Then
x = x + 1
y = Range("a4:o4").Find(arr(i, 3)).Column
ReDim Preserve brr(1 To 11, 1 To x)
For z = 1 To 10
brr(z, x) = arr(n, z)
Next
If x > 1 Then
brr(11, x) = brr(11, x - 1) + arr(n, 4) + arr(n, 5) + arr(n, 6) + arr(n, 7) + arr(n, 8) + arr(n, 9)
Else
brr(11, 1) = arr(3, y)
brr(11, x) = brr(11, x) + arr(n, 4) + arr(n, 5) + arr(n, 6) + arr(n, 7) + arr(n, 8) + arr(n, 9)
End If
End If
Next
Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
With ws
.Name = arr(i, 3)
.Range("a1").Resize(5, UBound(ar, 2)) = ar
.Range("k4") = arr(2, y)
.Range("k5") = arr(3, y)
.Range("a1:k1").Merge
.Range("a2:k2").Merge
For x = 1 To 10
.Range(.Cells(3, x), .Cells(4, x)).Merge
Next
.Range("a1:k4").HorizontalAlignment = xlCenter
.Range("a6").Resize(UBound(brr, 2), 11) = Application.Transpose(brr)
.Range("a:a").NumberFormatLocal = "yyyy-m-d"
x = .Range("a65536").End(xlUp).Row + 1
.Range("a" & x) = "合计"
.Range(.Cells(x, 1), .Cells(x, 6)).Merge
End With
Erase brr
x = 0
End If
Next
End Sub

复制代码

合计那里自己用函数算一下好了,VBA不太会搞

865232044 · 发表于 2014-2-24 18:06

各分表的项目1--项目4都是文字和总表的一致，项目5-项目6是数值，需要合计；各分表的余额应是期初余额加上项目5减去项目6的结果

865232044 · 发表于 2014-2-24 18:09

A公司的余额是对的，B公司的余额是错的，C公司的余额是对的，D公司的余额是错的

865232044 · 发表于 2014-2-24 18:09

请大师修改

独奏 · 发表于 2014-2-24 18:45

本帖最后由独奏于 2014-2-24 19:02 编辑

复制代码

独奏 · 发表于 2014-2-24 18:50

本帖最后由独奏于 2014-2-24 19:01 编辑

你用未拆分前那个表试试，我这试过没问题

865232044 · 发表于 2014-2-24 20:17

谢谢非常不错了，遗憾的是分表的合计没有；求大师再给做一个删除分表的宏吧，不好意思

独奏 · 发表于 2014-2-24 21:20

本帖最后由独奏于 2014-2-24 21:22 编辑

复制代码

SHEET1那里可以改为你不删除的工作表名

		自动登录	找回密码
密码			注册