预算合价及按项目编码分级累进求和？真诚求助，急！

zengsijun

[atta预算合价及按项目编码分级累进求和？真诚求助，急！  因工作中遇到问题，急需此VBA，烦请大侠相助为盼！想用VBA实现G列的效果，一是清单子目工程量*合同单价=单项合价；二是将单项合价按A列项目编码向上累进汇总，其具体效果见G列！



ch]1932503[/attach]

zengsijun

此表只为工作中一的一部分，具体数据非常多，请大侠相助，能支持层数越多越好，谢谢了！

zengsijun

急，顶上去，烦请各位高手相助！谢谢了！！！

hhjjpp

预算合价-h.rar (13.4 KB, 下载次数: 99)

2016-6-11 16:15 上传

点击文件名下载附件

zengsijun

hhjjpp 发表于 2016-6-11 16:15

谢谢了，能否帮我改成VBA的形式，谢谢！！

zengsijun

每天顶上去，谢谢楼主！！！

黑山上的鹰

给你一段代码，自己改
Sub 横向汇总录入表() '使用数组从上到下汇总
Dim ws As Worksheet
Dim fla As Boolean
Dim arr, brr()
Set ws = Worksheets("数据录入")
fla = False
hj = 0
' t = Timer
With ws
    r = .Cells(.Rows.Count, 1).End(xlUp).Row
    c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    arr = .Range(.Cells(3, 1), .Cells(r, c))
End With
ReDim brr(1 To UBound(arr, 2))
hs = UBound(arr)
For i = hs - 1 To 1 Step -1
    BM = CStr(arr(i, 1))
    j = i + 1
    Do While CStr(arr(j, 1)) Like BM & "*"
        If CStr(arr(j, 1)) Like BM & "??" Then
            For k = 5 To c
                'For k = 3 To c
                brr(k) = brr(k) + arr(j, k)
            Next
            fla = True
        End If
        j = j + 1
        If j > hs Then Exit Do
    Loop
    If fla Then
        'For k = 3 To c
        For k = 5 To c
            arr(i, k) = brr(k)
        Next
        ReDim brr(1 To UBound(arr, 2))
        fla = False
    End If
Next
Worksheets("数据录入").Range("a3").Resize(UBound(arr), UBound(arr, 2)) = arr
' MsgBox Timer - t
End Sub

zengsijun

谢谢楼主，我试试下！

zengsijun

黑山上的鹰 发表于 2016-6-16 10:54
给你一段代码，自己改
Sub 横向汇总录入表() '使用数组从上到下汇总
Dim ws As Worksheet

我不会改，能否帮我改下，谢谢！！

黑山上的鹰

zengsijun 发表于 2016-6-17 10:57
我不会改，能否帮我改下，谢谢！！

看是不是这样的，找不到规律，增加了一个辅助列。 预算合价-h.rar (23.71 KB, 下载次数: 71)

2016-6-17 12:36 上传

点击文件名下载附件