[已解决]根据统计个数生成固定行数

traknox

各位好，我现在在做公司的一个模板，希望能得到大家帮助。

比如我在Sheet1中输入了以下信息


在Sheet2中，能根据分系统的个数，对sheet2的第2行进行复制，每个分系统复制大概50~100行（复制的行数可以自行定义）。


谢谢！

最佳答案

月排行榜 / 总排行榜

grf1973

2015-12-7 14:19

1. Sub test()
   
2.     Dim x As Integer, arr, m As Integer
   
3.     Set d = CreateObject("SCRIPTING.DICTIONARY")
   
4.     Set d1 = CreateObject("SCRIPTING.DICTIONARY")
   
5.     arr = Sheets(1).Range("e2:f" & Sheets(1).Range("e65536").End(3).Row)
   
6.     n = InputBox("请输入每个分系统需要的个数", , 100)
   
7.     ReDim brr(1 To n * UBound(arr), 1 To 3)
   
8.     For x = 1 To UBound(arr)
   
9.         For j = 1 To n
   
10.             k = k + 1
    
11.             brr(k, 1) = k
    
12.             brr(k, 2) = arr(x, 1)
    
13.             brr(k, 3) = arr(x, 2)
    
14.         Next
    
15.     Next
    
16.     With Sheets(2)
    
17.         .[a2].Resize(10000, 3).ClearContents
    
18.         .[a2].Resize(k, 3) = brr
    
19.     End With
    
20. End Sub
    

复制代码

跳转到最佳答案楼层

七彩屋

请上传附件，代码不难写。

traknox

七彩屋 发表于 2015-12-7 10:56
请上传附件，代码不难写。

报价模板.rar (35.32 KB, 下载次数: 4)

2015-12-7 12:20 上传

点击文件名下载附件
报价模板

请看看，谢谢！

traknox

七彩屋 发表于 2015-12-7 10:56
请上传附件，代码不难写。

请以此为准，谢谢！

tzjx200521

traknox 发表于 2015-12-7 12:19
请以此为准，谢谢！

1. Sub test()
   
2.     Dim x As Integer, arr, m As Integer
   
3.     m = Range("e65536").End(3).Row
   
4.     Set d = CreateObject("SCRIPTING.DICTIONARY")
   
5.     Set d1 = CreateObject("SCRIPTING.DICTIONARY")
   
6.     arr = Range("e2:f" & m)
   
7. 
   
8.     For x = 1 To UBound(arr)
   
9.         d(arr(x, 1)) = 1
   
10.         d1(arr(x, 2)) = 1
    
11.     Next
    
12.     a = d.Count
    
13.     b = d1.Count
    
14.     Range("j1") = a
    
15.     Range("j2") = b
    
16. End Sub
    

复制代码

请测试看看。

grf1973

1. Sub test()
   
2.     Dim x As Integer, arr, m As Integer
   
3.     Set d = CreateObject("SCRIPTING.DICTIONARY")
   
4.     Set d1 = CreateObject("SCRIPTING.DICTIONARY")
   
5.     arr = Sheets(1).Range("e2:f" & Sheets(1).Range("e65536").End(3).Row)
   
6.     n = InputBox("请输入每个分系统需要的个数", , 100)
   
7.     ReDim brr(1 To n * UBound(arr), 1 To 3)
   
8.     For x = 1 To UBound(arr)
   
9.         For j = 1 To n
   
10.             k = k + 1
    
11.             brr(k, 1) = k
    
12.             brr(k, 2) = arr(x, 1)
    
13.             brr(k, 3) = arr(x, 2)
    
14.         Next
    
15.     Next
    
16.     With Sheets(2)
    
17.         .[a2].Resize(10000, 3).ClearContents
    
18.         .[a2].Resize(k, 3) = brr
    
19.     End With
    
20. End Sub
    

复制代码

七彩屋

traknox 发表于 2015-12-7 12:19
请以此为准，谢谢！

你要的最后结果不明确

traknox

grf1973 发表于 2015-12-7 14:19

您好，您编的程序没问题，谢谢您。
由于公司保密的要求，所以我没有把信息都透露。其实我这个表是做了数据透视表的，而做数据透视表的时候似乎就无法使用这个程序了。

运行出错

非常感谢您的无私帮助！

traknox

tzjx200521 发表于 2015-12-7 13:05
请测试看看。

您这个与我的要求有点不太一样，到了100多行就停止了。
还是很感谢您的反馈！