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

zengsijun · 发表于 2016-6-11 14:13

本帖最后由 zengsijun 于 2016-6-11 14:16 编辑

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

ch]1932503[/attach] QQ图片20160611141159.png

zengsijun · 发表于 2016-6-11 14:17

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

zengsijun · 发表于 2016-6-11 14:26

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

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

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

zengsijun · 发表于 2016-6-16 09:42

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

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

zengsijun · 发表于 2016-6-16 10:06

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

黑山上的鹰 · 发表于 2016-6-16 10:54

给你一段代码，自己改
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 · 发表于 2016-6-17 10:54

谢谢楼主，我试试下！

zengsijun · 发表于 2016-6-17 10:57

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

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

黑山上的鹰 · 发表于 2016-6-17 12:36

本帖最后由黑山上的鹰于 2016-6-17 12:38 编辑

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

看是不是这样的，找不到规律，增加了一个辅助列。

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

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分