vba代码按字符串长度汇总计算，谢谢！

hcy1185

ykcbf1100 发表于 2024-12-9 17:04
我不用正则了，你再试一下。

可以，还有6位字符串、4位字符串长度的计算没有代码，请老师看看，谢谢！！！

ykcbf1100

hcy1185 发表于 2024-12-9 17:09
可以，还有6位字符串、4位字符串长度的计算没有代码，请老师看看，谢谢！！！

达到目的就行了。方法可以有很多种。

hcy1185

小凡、、、 发表于 2024-12-9 15:13
这样的结果？对不同长度的去重求和

你好！数据翻了一倍，请指教！！！

chxw68

参与一下。

翁知江安

Sub huiz()
Dim i, irow
Dim ar
Dim d1, d2, d3, d4, d5, d6 As Object
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
Set d4 = CreateObject("scripting.dictionary")
Set d5 = CreateObject("scripting.dictionary")
Set d6 = CreateObject("scripting.dictionary")
irow = Sheets("龙凤煤矿资产盘点表").[a65536].End(xlUp).Row
ar = Sheets("龙凤煤矿资产盘点表").Range("a1:g" & irow)
For i = 4 To irow
    If ar(i, 6) <> "" Then
    d3(Left(ar(i, 2), 8)) = d3(Left(ar(i, 2), 8)) + ar(i, 6)
    d2(Left(ar(i, 2), 6)) = d2(Left(ar(i, 2), 6)) + ar(i, 6)
    d1(Left(ar(i, 2), 4)) = d1(Left(ar(i, 2), 4)) + ar(i, 6)
    End If
    If ar(i, 7) <> "" Then
    d6(Left(ar(i, 2), 8)) = d6(Left(ar(i, 2), 8)) + ar(i, 7)
    d5(Left(ar(i, 2), 6)) = d5(Left(ar(i, 2), 6)) + ar(i, 7)
    d4(Left(ar(i, 2), 4)) = d4(Left(ar(i, 2), 4)) + ar(i, 7)
    End If
Next
With Sheets("龙凤煤矿资产盘点表")
For i = 4 To irow
   If .Cells(i, 6) = "" And Len(.Cells(i, 2)) <= 8 Then
     If Len(.Cells(i, 2)) = 4 Then
         .Cells(i, 6) = d1(.Cells(i, 2).Value)
         Else
          If Len(.Cells(i, 2)) = 6 Then
           .Cells(i, 6) = d2(.Cells(i, 2).Value)
            Else
            .Cells(i, 6) = d3(.Cells(i, 2).Value)
          End If
       End If
    End If
     If .Cells(i, 7) = "" Or Len(.Cells(i, 2)) <= 8 Then
       If Len(.Cells(i, 2)) = 4 Then
         .Cells(i, 7) = d4(.Cells(i, 2).Value)
         Else
          If Len(.Cells(i, 2)) = 6 Then
           .Cells(i, 7) = d5(.Cells(i, 2).Value)
            Else
            .Cells(i, 7) = d6(.Cells(i, 2).Value)
          End If
       End If
    End If
Next
End With
MsgBox "ok"
End Sub

chxw68

14楼的代码逻辑有点错误。

hcy1185

chxw68 发表于 2024-12-9 22:08
14楼的代码逻辑有点错误。

衷心感谢！！！！

hcy1185

chxw68 发表于 2024-12-9 22:08
14楼的代码逻辑有点错误。

chxw68老师！无法解压

hcy1185

根据3楼小凡老师的代码做了修改，问题完美解决。表示感谢！
Sub 按字符串长度汇总计算()
Dim d As Object, arr As Variant, r As Integer, x As Integer, i As Integer
Dim st As String, k, m As Integer
   
Set d = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("龙凤煤矿资产盘点表")
    r = .Range("a65536").End(xlUp).Row
    ' 清除F、G列对应数据
    For x = 8 To 4 Step -2
        For i = r To 4 Step -1
            st = Left(.Cells(i, 2), x)
            If .Cells(i, 2) = st Then
                .Range("F" & i & ":G" & i) = ""
                .Cells(i, "F").NumberFormat = "General"
                .Cells(i, "G").NumberFormat = "0"
            End If ' 下面两行代码是对应编码的行底纹加颜色
            If Len(.Cells(i, 2)) = 8 Then .Range("a" & i & ":G" & i).Interior.Color = RGB(255, 255, 0)
            If Len(.Cells(i, 2)) = 6 Then .Range("a" & i & ":G" & i).Interior.Color = RGB(173, 216, 230)
        Next i
    Next x
    ' 单元格列写入字典
    For x = 8 To 4 Step -2
        For i = r To 4 Step -1
            st = Left(.Cells(i, 2), x)
            If Not d.exists(st) Then
                d(st) = Array(.Cells(i, "F"), .Cells(i, "G"))
            Else
                d(st) = Array(d(st)(0) + .Cells(i, "F"), d(st)(1) + .Cells(i, "G"))
            End If
        Next i
    Next x
    ' 字典数据写入单元格
    ReDim arr(1 To d.Count, 1 To 3)
    For i = r To 4 Step -1
        For Each k In d.keys
            If .Cells(i, 2) = k Then
                .Cells(i, "F") = WorksheetFunction.Transpose(d(k)(0))
                .Cells(i, "G") = Round(WorksheetFunction.Transpose(d(k)(1)), 0)
            End If
            'm = m + 1
            'arr(m, 1) = k
            'arr(m, 2) = d(k)(0)
            'arr(m, 3) = d(k)(1)
        Next k
    Next i
    '.[i4].Resize(UBound(arr), 3) = arr
End With
End Sub

chxw68

我下载解压都正常，重新上传一份请楼主试试。