[已解决]根据数量复制行数

wgxfhi11

请问如何根据数量复制行数，谢谢帮忙

最佳答案

月排行榜 / 总排行榜

白开水的微笑

2015-4-27 13:32

1. Sub Test()
   
2.     Dim arrData
   
3.     Dim arrResult
   
4.     Dim lCount  As Long
   
5.     Dim lTotal  As Long
   
6.     Dim lRowN1  As Long
   
7.     Dim lRowN2  As Long
   
8.     Dim lColN   As Long
   
9.    
   
10.     arrData = Sheet1.Range("A1").CurrentRegion.Value
    
11.     lTotal = WorksheetFunction.Sum(Sheet1.Range("E:E"))
    
12.    
    
13.     ReDim arrResult(1 To lTotal + 1, 1 To UBound(arrData, 2))
    
14.     'Copy Title
    
15.     For lColN = 1 To UBound(arrData, 2)
    
16.         arrResult(1, lColN) = arrData(1, lColN)
    
17.     Next lColN
    
18.     lRowN2 = 2
    
19.     For lRowN1 = 2 To UBound(arrData, 1)
    
20.         'Get Total
    
21.         lTotal = CLng(arrData(lRowN1, 5))
    
22.         
    
23.         Do While lTotal > 0
    
24.             'Copy
    
25.             For lColN = 1 To UBound(arrData, 2)
    
26.                 arrResult(lRowN2, lColN) = arrData(lRowN1, lColN)
    
27.             Next lColN
    
28.             'Count=1
    
29.             arrResult(lRowN2, 5) = 1
    
30.             lTotal = lTotal - 1
    
31.             lRowN2 = lRowN2 + 1
    
32.         Loop
    
33.         
    
34.     Next lRowN1
    
35.     With Sheet2
    
36.         .Cells.Clear
    
37.         .Range("A1").Resize(UBound(arrResult), UBound(arrResult, 2)).Value = arrResult
    
38.         .Activate
    
39.     End With
    
40. End Sub

复制代码

跳转到最佳答案楼层

雪舞子

1. Sub test()
   
2.     Dim arr, ar, brr(100, 1 To 6), i%, j%, k%, n%
   
3.     arr = [a1].CurrentRegion
   
4.     For i = 2 To UBound(arr)
   
5.         For j = 1 To arr(i, 5)
   
6.             n = n + 1
   
7.             For k = 1 To 6
   
8.                 If k <> 5 Then
   
9.                     
   
10.                     brr(n, k) = arr(i, k)
    
11.                 End If
    
12.                
    
13.             Next
    
14.             brr(n, 5) = 1
    
15.         Next
    
16.     Next
    
17.     ar = Array("ID", "码号", "产品", "名称", "数量", "地点")
    
18.     For i = 1 To 6
    
19.         brr(0, i) = ar(i - 1)
    
20.     Next
    
21.     [a10].Resize(n, 6) = brr
    
22. End Sub

复制代码

11.rar (12.77 KB, 下载次数: 1)

2015-4-27 13:30 上传

点击文件名下载附件

白开水的微笑

1. Sub Test()
   
2.     Dim arrData
   
3.     Dim arrResult
   
4.     Dim lCount  As Long
   
5.     Dim lTotal  As Long
   
6.     Dim lRowN1  As Long
   
7.     Dim lRowN2  As Long
   
8.     Dim lColN   As Long
   
9.    
   
10.     arrData = Sheet1.Range("A1").CurrentRegion.Value
    
11.     lTotal = WorksheetFunction.Sum(Sheet1.Range("E:E"))
    
12.    
    
13.     ReDim arrResult(1 To lTotal + 1, 1 To UBound(arrData, 2))
    
14.     'Copy Title
    
15.     For lColN = 1 To UBound(arrData, 2)
    
16.         arrResult(1, lColN) = arrData(1, lColN)
    
17.     Next lColN
    
18.     lRowN2 = 2
    
19.     For lRowN1 = 2 To UBound(arrData, 1)
    
20.         'Get Total
    
21.         lTotal = CLng(arrData(lRowN1, 5))
    
22.         
    
23.         Do While lTotal > 0
    
24.             'Copy
    
25.             For lColN = 1 To UBound(arrData, 2)
    
26.                 arrResult(lRowN2, lColN) = arrData(lRowN1, lColN)
    
27.             Next lColN
    
28.             'Count=1
    
29.             arrResult(lRowN2, 5) = 1
    
30.             lTotal = lTotal - 1
    
31.             lRowN2 = lRowN2 + 1
    
32.         Loop
    
33.         
    
34.     Next lRowN1
    
35.     With Sheet2
    
36.         .Cells.Clear
    
37.         .Range("A1").Resize(UBound(arrResult), UBound(arrResult, 2)).Value = arrResult
    
38.         .Activate
    
39.     End With
    
40. End Sub

复制代码