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

865232044

编辑拆分工作表拆分vba， 希望将拆分前的工作表拆分后变成拆分后的工作表。望各位大神帮忙

最佳答案

月排行榜 / 总排行榜

独奏

2014-2-23 19:27

1. Sub test()
   
2. Dim arr, brr(), d, i, n, x, y, z
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a3:o" & Range("a65536").End(xlUp).Row)
   
5. ar = Sheet1.Range("a3:j4")
   
6. For i = 4 To UBound(arr)
   
7.     If Not d.exists(arr(i, 3)) Then
   
8.         d(arr(i, 3)) = ""
   
9.         For n = 4 To UBound(arr)
   
10.             If arr(n, 3) = arr(i, 3) Then
    
11.                 x = x + 1
    
12.                 y = Range("a4:o4").Find(arr(i, 3)).Column
    
13.                 ReDim Preserve brr(1 To 11, 1 To x)
    
14.                 For z = 1 To 10
    
15.                     brr(z, x) = arr(n, z)
    
16.                 Next
    
17.                 If x > 1 Then
    
18.                     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)
    
19.                 Else
    
20.                     brr(11, 1) = arr(3, y)
    
21.                     brr(11, x) = brr(11, x) + arr(n, 4) + arr(n, 5) + arr(n, 6) + arr(n, 7) + arr(n, 8) + arr(n, 9)
    
22.                 End If
    
23.             End If
    
24.         Next
    
25.         Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
    
26.         With ws
    
27.             .Name = arr(i, 3)
    
28.             .Range("a1").Resize(2, UBound(ar, 2)) = ar
    
29.             .Range("a3").Resize(UBound(brr, 2), 11) = Application.Transpose(brr)
    
30.             .Range("a:a").NumberFormatLocal = "yyyy-m-d"
    
31.         End With
    
32.         Erase brr
    
33.         x = 0
    
34.     End If
    
35. Next
    
36. End Sub
    

复制代码

跳转到最佳答案楼层

865232044

编辑拆分工作表拆分vba， 希望将拆分前的工作表拆分后变成拆分后的工作表，请看附件。望各位大神帮忙

我心飞翔410

怎么读的云里雾里的啊

865232044

怎么了

865232044

就是将总表拆分 按某一列的内容进行拆分呀

独奏

1. Sub test()
   
2. Dim arr, brr(), d, i, n, x, y, z
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a3:o" & Range("a65536").End(xlUp).Row)
   
5. ar = Sheet1.Range("a3:j4")
   
6. For i = 4 To UBound(arr)
   
7.     If Not d.exists(arr(i, 3)) Then
   
8.         d(arr(i, 3)) = ""
   
9.         For n = 4 To UBound(arr)
   
10.             If arr(n, 3) = arr(i, 3) Then
    
11.                 x = x + 1
    
12.                 y = Range("a4:o4").Find(arr(i, 3)).Column
    
13.                 ReDim Preserve brr(1 To 11, 1 To x)
    
14.                 For z = 1 To 10
    
15.                     brr(z, x) = arr(n, z)
    
16.                 Next
    
17.                 If x > 1 Then
    
18.                     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)
    
19.                 Else
    
20.                     brr(11, 1) = arr(3, y)
    
21.                     brr(11, x) = brr(11, x) + arr(n, 4) + arr(n, 5) + arr(n, 6) + arr(n, 7) + arr(n, 8) + arr(n, 9)
    
22.                 End If
    
23.             End If
    
24.         Next
    
25.         Set ws = Worksheets.Add(after:=Sheets(Sheets.Count))
    
26.         With ws
    
27.             .Name = arr(i, 3)
    
28.             .Range("a1").Resize(2, UBound(ar, 2)) = ar
    
29.             .Range("a3").Resize(UBound(brr, 2), 11) = Application.Transpose(brr)
    
30.             .Range("a:a").NumberFormatLocal = "yyyy-m-d"
    
31.         End With
    
32.         Erase brr
    
33.         x = 0
    
34.     End If
    
35. Next
    
36. End Sub
    

复制代码

865232044

您提供的vba代码在运行时提示：“运行时错误’91‘ 对象变量或with块变量未设置”；请大师再完善；谢谢

冠军欧洲2010

没有啊，。大师的代码，运行正确啊。

865232044

谢谢大师，已经相当不错了，但是和我想要的还不太一样，望大师帮我完善；我想要的见附件；谢谢

865232044