汇总数据转换为明细数据（通过VBA插入行并复制）

pop2016rx

请高手帮忙，在线等……谢谢！

汇总数据转换为明细数据（通过VBA插入行并复制）

CC例例

1. Sub Test()
   
2.     Dim c As Range, Arr, i&, x%, y%
   
3.     x = Application.Sum([c:c])
   
4.     ReDim Arr(1 To x, 1 To 4)
   
5.     For Each c In Range("a2", [a65536].End(3))
   
6.         For i = 1 To c.Offset(, 2).Value
   
7.             y = y + 1
   
8.             Arr(y, 1) = c.Value
   
9.             Arr(y, 2) = c.Offset(, 1).Value
   
10.             Arr(y, 3) = 1
    
11.             Arr(y, 4) = c.Offset(, 3) / c.Offset(, 2)
    
12.         Next
    
13.     Next
    
14.     [i1].CurrentRegion.Offset(1).ClearContents
    
15.     [i2].Resize(x, 4) = Arr
    
16. End Sub

复制代码

CC例例

>>>>>>>>>>>>>>

pop2016rx

太给力了，学习了，谢谢啊！

yeminqiang

1. Sub cdsr()
   
2.     Dim arr, brr(), i&, j&, k&
   
3.     With Sheet1
   
4.         arr = .[a1].CurrentRegion
   
5.         s = Application.Sum(.[c2:c60000])
   
6.     End With
   
7.     ReDim brr(1 To s, 1 To 4)
   
8.     For i = 2 To UBound(arr)
   
9.         For j = 1 To arr(i, 3)
   
10.             k = k + 1
    
11.             brr(k, 1) = arr(i, 1)
    
12.             brr(k, 2) = arr(i, 2)
    
13.             brr(k, 3) = 1
    
14.             brr(k, 4) = arr(i, 2)
    
15.         Next
    
16.     Next
    
17.     With Sheet2
    
18.         .Cells.ClearContents
    
19.         .[a1:d1] = Array("名称", "单价", "数量", "金额")
    
20.         .[a2].Resize(k, 4) = brr
    
21.     End With
    
22. End Sub
    

复制代码

yeminqiang

汇总数据转换为明细数据（通过VBA插入行并复制）.rar (15 KB, 下载次数: 13)

2016-10-10 13:56 上传

点击文件名下载附件

pop2016rx

yeminqiang 发表于 2016-10-10 13:55

你好，再请教一下，领导又在名称后面加了一列规格，请问需要在哪个地方做修改，谢谢！

lsc900707

pop2016rx 发表于 2016-10-10 15:57
你好，再请教一下，领导又在名称后面加了一列规格，请问需要在哪个地方做修改，谢谢！

改成：
Sub cdsr()
    Dim arr, brr(), i&, j&, k&
    With Sheet1
        arr = .[a1].CurrentRegion
        s = Application.Sum(.[c2:c60000])
    End With
    ReDim brr(1 To s, 1 To 5)
    For i = 2 To UBound(arr)
        For j = 1 To arr(i, 4)
            k = k + 1
            brr(k, 1) = arr(i, 1)
            brr(k, 2) = arr(i, 2)
            brr(k, 3) = arr(i, 3)
            brr(k, 4) = 1
            brr(k, 5) = arr(i, 3)
        Next
    Next
    With Sheet2
        .Cells.ClearContents
        .[a1:e1] = Array("名称", "规格", "单价", "数量", "金额")
        .[a2].Resize(k, 5) = brr
    End With
End Sub

kszcs

yeminqiang 发表于 2016-10-10 13:55

Dim arr, brr(), i&, j&, k&
改为
Dim arr, brr(), i&, j&, k&,s
对吗

yeminqiang

kszcs 发表于 2016-10-10 16:25
Dim arr, brr(), i&, j&, k&
改为
Dim arr, brr(), i&, j&, k&,s

这个有木有强制声明的问题，这个问题就不多说了。一般来说声明一下好。像我等就很随意，因为都是小程序，代码》》》》