[已解决]请教如何用VBA从左边的数据自动生成右边这样的合计

大学好我是新来

VBA分类汇总。

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-7-23 22:19

试试看！！！！

跳转到最佳答案楼层

eennoo

1. Function total(ByVal data As Variant)
   
2. Dim reg As Object
   
3. Dim MatchChar, cols As Variant
   
4. Dim DataRows(0 To 2) As Double
   
5. Set reg = CreateObject("VbScript.RegExp")
   
6. cols = Array("填", "挖", "石方")
   
7. 
   
8.     For Each MatchChar In data
   
9.         For i = 0 To 2
   
10.             reg.Pattern = "^(?:" + cols(i) + ")(\d+$)|^(?:" + cols(i) + ")(\d+\.\d+$)"
    
11.             If reg.test(MatchChar) Then
    
12.             DataRows(i) = DataRows(i) + CDbl(reg.Replace(MatchChar, "$1$2"))
    
13.         
    
14.             Exit For
    
15.             End If
    
16.         Next
    
17.     Next
    
18.     total = DataRows
    
19. Set reg = Nothing
    
20. End Function
    
21. 
    
22. Sub main()
    
23. For i = 4 To 101
    
24. Range("L" & i).Resize(1.3) = total(Range("B" & i).Resize(1, 8))
    
25. Next
    
26. End Sub

复制代码

大学好我是新来

eennoo 发表于 2022-7-23 20:22

类似，但结果不对。 因为可能原数据是我这样的数据
要同一个桩号的填和挖及石方。各自要累加

hasyh2008

试试看！！！！

哥儿-

供参考

我行我速2008

Sub 清除()
    Range("K2").CurrentRegion.Offset(1).ClearContents
End Sub

Sub tt()
    Dim Ar, R%, C%, Reg, Str$, Br()
    清除
    Ar = [A1].CurrentRegion.Offset(2)
    ReDim Br(1 To UBound(Ar), 1 To 4)
    For R = 1 To UBound(Ar)
        For C = 1 To UBound(Ar, 2)
            Str = Ar(R, C)
            If InStr(Str, "K0+") Then
                Br(R, 1) = Str
            ElseIf InStr(Str, "填") Then
                Br(R, 2) = Application.Round(Br(R, 2) + TQ(Str, 1), 3)
            ElseIf InStr(Str, "挖") Then
                Br(R, 3) = Application.Round(Br(R, 3) + TQ(Str, 1), 3)
            ElseIf InStr(Str, "石方") Then
                Br(R, 4) = Application.Round(Br(R, 4) + TQ(Str, 1), 3)
            End If
        Next C
    Next R
    Range("K3").Resize(UBound(Ar), 4) = Br
End Sub

Function TQ(Str As String, Optional I As String = "1")
    Dim matches, match, A, S
    With CreateObject("vbscript.regexp")
        Select Case I
            Case "1": .Pattern = "\d+\.?\d+"
        End Select
        .Global = True
         Set matches = .Execute(Str)
         For Each match In matches
         A = A & S & match
        Next
        TQ = IIf(Len(A) > 0, A, "")
    End With
End Function

大学好我是新来

哥儿- 发表于 2022-7-24 08:49
供参考

很强啊，功能很厉害。。但是被分类中的桩号如果不是刚好在第一列，如果修改呢。

大学好我是新来

hasyh2008 发表于 2022-7-23 22:19
试试看！！！！

谢谢你，刚刚才看到内容，我测试了一下。当内容为整数的时候就出错了。

hasyh2008

Case "1": .Pattern = "\d+\.\d+"
这里加个问号，改为
Case "1": .Pattern = "\d+\.?\d+"

哥儿-

大学好我是新来 发表于 2022-7-25 19:46
很强啊，功能很厉害。。但是被分类中的桩号如果不是刚好在第一列，如果修改呢。

桩号是否在第一列没有任何影响，在第二列就改为arr（i,2),第三列arr(i,3)……第n列就arr（i，n),乱序不在一列上，if判断里面else来接收桩号，第二个for循环调成从1开始。