[已解决]拆分数据的问题

李全有

附件 按要求拆分数据.zip (252.55 KB, 下载次数: 12)

2015-4-7 13:54 上传

点击文件名下载附件
谢谢各位老师！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-4-7 14:47

代码可以简化一点：

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     s = Val(InputBox("请输入拆分次数"))
   
4.     r = UBound(arr)
   
5.     For i = 0 To s - 1      '拆分次数
   
6.         rc = r - 3 * i      '最大行
   
7.         p = rc / 3        '1/3处
   
8.         ReDim brr(1 To r / 3, 1 To 11)
   
9.         For k = 1 To rc
   
10.             n = IIf(k <= p, k, IIf(k <= 2 * p, k - p, k - 2 * p))
    
11.             c = IIf(k <= p, 1, IIf(k <= 2 * p, 5, 9))
    
12.             brr(n, c) = arr(k, 1): brr(n, c + 1) = arr(k, 2): brr(n, c + 2) = arr(k, 3)
    
13.         Next
    
14.         Sheets.Add after:=Sheets(Sheets.Count)
    
15.         With ActiveSheet
    
16.             .Name = "第" & i + 1 & "次"
    
17.             .[a1].Resize(UBound(brr), 11) = brr
    
18.         End With
    
19.     Next
    
20. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     s = Val(InputBox("请输入拆分次数"))
   
4.     r = UBound(arr)
   
5.     For i = 0 To s - 1      '拆分次数
   
6.         rc = r - 3 * i      '最大行
   
7.         p = rc / 3        '1/3处
   
8.         ReDim brr(1 To r / 3, 1 To 11)
   
9.         For k = 1 To rc
   
10.             If k <= p Then
    
11.                 n = n + 1
    
12.                 brr(n, 1) = arr(k, 1): brr(n, 2) = arr(k, 2): brr(n, 3) = arr(k, 3)
    
13.             ElseIf k <= 2 * p Then
    
14.                 m = m + 1
    
15.                 brr(m, 5) = arr(k, 1): brr(m, 6) = arr(k, 2): brr(m, 7) = arr(k, 3)
    
16.             Else
    
17.                 l = l + 1
    
18.                 brr(l, 9) = arr(k, 1): brr(l, 10) = arr(k, 2): brr(l, 11) = arr(k, 3)
    
19.             End If
    
20.         Next
    
21.         Sheets.Add after:=Sheets(Sheets.Count)
    
22.         With ActiveSheet
    
23.             .Name = "第" & i + 1 & "次"
    
24.             .[a1].Resize(UBound(brr), 11) = brr
    
25.         End With
    
26.         n = 0: m = 0: l = 0
    
27.     Next
    
28. End Sub

复制代码

grf1973

代码可以简化一点：

1. Sub tt()
   
2.     arr = [a1].CurrentRegion
   
3.     s = Val(InputBox("请输入拆分次数"))
   
4.     r = UBound(arr)
   
5.     For i = 0 To s - 1      '拆分次数
   
6.         rc = r - 3 * i      '最大行
   
7.         p = rc / 3        '1/3处
   
8.         ReDim brr(1 To r / 3, 1 To 11)
   
9.         For k = 1 To rc
   
10.             n = IIf(k <= p, k, IIf(k <= 2 * p, k - p, k - 2 * p))
    
11.             c = IIf(k <= p, 1, IIf(k <= 2 * p, 5, 9))
    
12.             brr(n, c) = arr(k, 1): brr(n, c + 1) = arr(k, 2): brr(n, c + 2) = arr(k, 3)
    
13.         Next
    
14.         Sheets.Add after:=Sheets(Sheets.Count)
    
15.         With ActiveSheet
    
16.             .Name = "第" & i + 1 & "次"
    
17.             .[a1].Resize(UBound(brr), 11) = brr
    
18.         End With
    
19.     Next
    
20. End Sub

复制代码