Excel合并和排序VBA无法正常工作

9rygscc1 于 2023-02-14 发布在其他

关注(0)|答案(1)|浏览(138)

这个VBA只在G列的值相同的情况下求和。我需要它来求和。
以下是原始数据，蓝色和红色项目将合并，并汇总总数
enter image description here
运行VBA后，我得到以下内容
enter image description here
所以蓝色的项目按预期工作，红色的项目没有。蓝色的项目加在一起，因为它们是相同的。无论如何都需要它们加在一起
下面是代码

Sub test()
    Dim fn As String, a, x, s As String, i As Long, n As Long, temp
    fn = Application.GetOpenFilename("CSVFiles,*.csv")
    If fn = "False" Then Exit Sub
    x = Split(CreateObject("Scripting.FileSystemObject").OpenTextFile(fn).ReadAll, vbNewLine)
    ReDim a(1 To UBound(x) + 1, 1 To 1)
    With CreateObject("Scripting.Dictionary")
        For i = 0 To UBound(x)
            If x(i) <> "" Then
                s = Split(x(i), ",", 2)(1)
                If Not .exists(s) Then
                    .Item(s) = .Count + 1
                    a(.Count, 1) = x(i)
                Else
                    temp = Split(a(.Item(s), 1), ",")
                    temp(0) = temp(0) & Chr(2) & Split(x(i), ",")(0)
                    temp(6) = Val(temp(6)) + Val(Split(x(i), ",")(6))
                    a(.Item(s), 1) = Join(temp, ",")
                End If
            End If
        Next
    End With
    With Cells(1).Resize(UBound(a, 1))
        .CurrentRegion.ClearContents
        .Value = a
        .TextToColumns .Cells(1), 1, comma:=True
        .Replace Chr(2), ", ", 2
        .CurrentRegion.Columns.AutoFit
    End With
End Sub

我一直试图修改VBA，但最终打破了它更多

excel

来源：https://stackoverflow.com/questions/75374819/excel-combine-and-sort-vba-not-working-right

1条答案

按热度按时间

1aaf6o9v1#

将字典键限制为要聚合的4个字段。

Sub test()

    Dim fn As String, ts, arCSV, ar, arOut
    Dim i As Long, n As Long, r As Long, iCount As Long
    Dim s As String, key As String, sCanopy As String
    Dim t0 As Single
    
    fn = Application.GetOpenFilename("CSVFiles,*.csv")
    If fn = "False" Then Exit Sub
    
    With CreateObject("Scripting.FileSystemObject")
          Set ts = .OpenTextFile(fn)
          s = ts.readall
          ts.Close
    End With
    
    ' split text into array of lines
    t0 = Timer
    arCSV = Split(s, vbNewLine)
    ReDim arOut(1 To UBound(arCSV) + 1, 1 To 1)
    
    n = 0
    With CreateObject("Scripting.Dictionary")
    
        For i = 0 To UBound(arCSV)
            ar = Split(arCSV(i), ",")
            If UBound(ar) >= 10 Then
                ' 4 key fields Descr,Size,Cut Length, Finish
                key = Trim(ar(3)) & "_" & Trim(ar(4)) & "_" & Trim(ar(7)) & "_" & Trim(ar(10))
                
                sCanopy = ar(0) ' aggregate with comma
                iCount = Val(ar(6)) ' summate
                
                If .Exists(key) Then
                    r = .Item(key)
                    
                    ' modify array
                    ar = Split(arOut(r, 1), ",")
                    
                    ' add canopy if not already in col 0
                    If InStr(ar(0), sCanopy) = 0 Then
                        ar(0) = ar(0) & Chr(2) & sCanopy
                    End If
                    ' total count
                    ar(6) = ar(6) + iCount
                    arOut(r, 1) = Join(ar, ",")
                  
                ElseIf Len(key) > 0 Then
                    n = n + 1
                    .Add key, n
                    arOut(n, 1) = arCSV(i)
                End If
            End If
        Next
    End With
    
    With Cells(1).Resize(n)
        .CurrentRegion.ClearContents
        .Value = arOut
        .TextToColumns .Cells(1), 1, comma:=True
        .Replace Chr(2), ", ", 2
        .CurrentRegion.Columns.AutoFit
    End With
    
    MsgBox i - 1 & " rows scanned in " & fn, vbInformation, Format(Timer - t0, "0.0 secs")
    
End Sub

CSV测试文件

CANOPY,B1,PART,DESC,SIZE,,Count,CUT-LEN,,,FINISH
A2,,,BEAM,6x6,,10,71 3/8,,,MF
A2,,,BEAM,6x6,,2,69 3/8,,,MF
B2,,,BEAM,6x6,,4,59 3/8,,,MF
B2,,,BEAM,6x6,,5,89 3/8,,,MF
B2,,,BEAM,6x6,,2,57 3/8,,,MF
A1,,,BEAM,6x6,,12,71 3/8,,,MF
A1,,,BEAM,6x6,,2,69 3/8,,,MF
B1,,,BEAM,6x6,,4,59 3/8,,,MF
B1,,,BEAM,6x6,,5,89 3/8,,,MF
B1,,,BEAM,6x6,,2,57 3/8,,,MF
A4,,,BEAM,6x6,,15,71 3/8,,,MF
A4,,,BEAM,6x6,,2,69 3/8,,,MF
B4,,,BEAM,6x6,,4,59 3/8,,,MF
B4,,,BEAM,6x6,,5,89 3/8,,,MF
B4,,,BEAM,6x6,,2,57 3/8,,,MF
A3,,,BEAM,6x6,,16,71 3/8,,,MF
A3,,,BEAM,6x6,,2,69 3/8,,,MF
B3,,,BEAM,6x6,,4,59 3/8,,,MF
B3,,,BEAM,6x6,,5,89 3/8,,,MF
B3,,,BEAM,6x6,,2,57 3/8,,,MF

赞(0）回复(0）举报 2023-02-14

我来回答

Excel合并和排序VBA无法正常工作

1条答案

相关问题

热门标签

最新问答