合并相同单位项求助

Dragonfly7995

各位大神，请指点，在G列到K列，是一些带单位的数字，如何用VBA将相同单位的数据进行求和，达到M列的效果，谢谢!

microyip

用正则把数字和单位分开，然后用字典合并一下单位就可以了

Jason_WangSS

microyip 发表于 2019-9-9 12:13
用正则把数字和单位分开，然后用字典合并一下单位就可以了

好想法,本来还想先人工统计一下单位,再用字典筛选,想到扩展性不高,正则又不太会,就不动手了

microyip

Jason_WangSS 发表于 2019-9-9 13:09
好想法,本来还想先人工统计一下单位,再用字典筛选,想到扩展性不高,正则又不太会,就不动手了

就算不用正则，用Val+Split也可以分离数值与单位啊

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, cnt, a, b, t
  arr = Range("g4:l" & [d4].End(xlDown).Row)
  ReDim brr(1 To UBound(arr, 1), 1 To 1)
  For i = 1 To UBound(arr, 1)
    ReDim mark(1 To 2, 1 To UBound(arr, 2))
    cnt = 0
    For j = 1 To UBound(arr, 2)
      If Len(arr(i, j)) Then
        For k = 1 To Len(arr(i, j))
          If Not IsNumeric(Mid(arr(i, j), k, 1)) Then
            a = Val(Left(arr(i, j), k - 1))
            b = Mid(arr(i, j), k)
            Exit For
          End If
        Next
        For k = 1 To cnt
          If mark(2, k) = b Then
            mark(1, k) = mark(1, k) + a
            Exit For
          End If
        Next
        If k = cnt + 1 Then
          cnt = cnt + 1
          mark(1, k) = a: mark(2, k) = b
        End If
      End If
    Next
    If cnt > 0 Then
      For j = 1 To cnt
        t = t & "," & mark(1, j) & mark(2, j)
      Next
      brr(i, 1) = Mid(t, 2): t = vbNullString
    End If
  Next
  [m4].Resize(UBound(brr, 1)) = brr
End Sub

xiangbaoan

Option Explicit
Sub test()
Dim ar, d As Object, i&, j&, k, s$, t$, v#
ar = Range("g4:l" & [d4].End(xlDown).Row)
ReDim br$(1 To UBound(ar), 0)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ar)
    d.RemoveAll
    For j = 1 To UBound(ar, 2)
        t = Replace(ar(i, j), Space(1), "")
        If Len(t) Then
            v = Val(t)
            If v Then d(Replace(t, v, "")) = d(Replace(t, v, "")) + v
        End If
    Next
    s = ""
    If d.Count Then
        For Each k In d.keys
            s = s & "," & d(k) & k
        Next
        br(i, 0) = Mid(s, 2)
    End If
Next
[m4].Resize(UBound(br)) = br
Set d = Nothing
End Sub

everbest2015

xiangbaoan 发表于 2019-9-10 08:38
Option Explicit
Sub test()
Dim ar, d As Object, i&, j&, k, s$, t$, v#

还从来没用过这种写法    ReDim br$(1 To UBound(ar), 0)    学习了。  思路很好

xiangbaoan

everbest2015 发表于 2019-9-10 09:49
还从来没用过这种写法    ReDim br$(1 To UBound(ar), 0)    学习了。  思路很好

偷懒写法，为论坛省几个字符……

everbest2015

Sub 单位合并()
    Dim sh As Worksheet, ar, d As Object, i&, j&, r&, k, s$, Jia As Double, Dan As String
    Set sh = ThisWorkbook.Sheets("汇总")
    With sh
        r = .Cells(Rows.Count, "a").End(3).Row
        If r <= 3 Then Exit Sub
        ar = .Range("a4:m" & r)
        Set d = CreateObject("scripting.dictionary")
        For i = 1 To UBound(ar)
            For j = 7 To UBound(ar, 2) - 1
                s = ar(i, j)
                If s <> "" Then
                    Jia = Val(s)
                    Dan = Replace(s, Jia, "")
                    d(Dan) = d(Dan) + Jia
                End If
            Next
            s = ""
            If d.Count > 0 Then
                For Each k In d.keys
                    If s = "" Then
                        s = d(k) & k
                    Else
                        s = s & "," & d(k) & k
                    End If
                Next
                ar(i, 13) = s
                d.RemoveAll
            End If
        Next
         .Range("a4:m" & r) = ar
    End With
End Sub