[求助]利用字典-合并达到条件的数据 & 其余的照样填写

[qq_33986247]

求大神帮助，如何利用字典做到处理批量数据合并(不只范例中14笔, 是动态数据), 部分数据保持一样, 部分要加上斜线append在同一储存框
上面的是原生数据



下面的是合并规则是根据 -> A高铁站 & E车型种类 & F别号是一样

A高铁站 & E车型种类 & F别号是一样的情况下 -> B趟 相加 ; C票价 相加 ; D 发车准时率 取最高值 ; G备注 加上斜线append在同一储存框

[A1:G1]格是要保持一样

求大神了

[X-i-n]

字什么典啊，这是经典的数据透视表的场景

[ZHRXJR]

现在谁还在使用字典，直接操作Excel 或 使用ADO操作Excel都比较简单，你的这个问题，用上述方法操作，应该没有问题。

[hitzsf]

Option Explicit

Sub merget()
    Application.ScreenUpdating = False

    Dim dic As Object
    
    Dim rng As Range
    Set dic = CreateObject("scripting.dictionary")
    
    Set rng = Worksheets("Sheet1").UsedRange
    
    Dim i As Integer, j As Integer
    
    Dim key As String
    Dim row As Integer, krow As Integer
    row = 1
    
    Dim findStr As Integer
    For i = 1 To rng.Rows.Count
        key = rng.Cells(i, 1).Value & rng.Cells(i, 6).Value
        'Debug.Print key
        If key = "" Then GoTo LINE

        If (dic.exists(key)) Then
            krow = dic(key)
            Cells(krow, 2).Value = Val(Cells(krow, 2).Value) + Val(rng(i, 2).Value)
            Cells(krow, 3).Value = Val(Cells(krow, 3).Value) + Val(rng(i, 3).Value)
            findStr = InStr(Cells(krow, 7).Value, rng(i, 7).Value)
            If findStr = 0 Then
                If StrComp(Cells(krow, 7).Value, rng(i, 7).Value) < 0 Then
                    Cells(krow, 7).Value = Cells(krow, 7).Value & "/" & rng(i, 7).Value
                Else
                    Cells(krow, 7).Value = rng(i, 7).Value & "/" & Cells(krow, 7).Value
                End If
            End If
        Else
            dic.Item(key) = row
            rng(i, 1).Resize(1, 7).Copy
            Range(Cells(row, 1), Cells(row, 7)).PasteSpecial xlPasteValuesAndNumberFormats
            row = row + 1
         End If
LINE:
    Next i
   Application.ScreenUpdating = True
End Sub