用VBA实现数据合并

用VBA实现数据合并

答：通过程序运行结果发现，题目中的转换后的数据存在部分冗余，如下图，在左边合并前的数据清单中不存在这类记录。所以转换后是不包含这9行记录的。

代码：
Sub Demo()
    Dim D As Object, SubD As Object
    Dim Rng As Range
    Dim TempStr As String, CurKey As String, CurItem As String, NewKey As String
    Dim i As Integer

    Set Rng = Range("B2")
    Set D = CreateObject("scripting.dictionary")
    Do Until IsEmpty(Rng)
        TempStr = Rng.Offset(0, -1) & "#" & Rng
        If Not D.exists(TempStr) Then
            Set D.Item(TempStr) = CreateObject("scripting.dictionary")
            D.Item(TempStr)(Rng.Offset(0, 1).Value) = Rng.Offset(0, 2).Value
        Else
            CurKey = Filter(D.Item(TempStr).keys, "")(0)
            CurItem = Filter(D.Item(TempStr).items, "")(0)
            If InStr(1, CurKey, Rng.Offset(0, 1).Value) = 0 Then
                NewKey = CurKey & "；" & Rng.Offset(0, 1).Value
                D.Item(TempStr).Key(CurKey) = NewKey
                D.Item(TempStr).Item(NewKey) = D.Item(TempStr).Item(NewKey) & "；" & Rng.Offset(0, 2).Value
            Else
                If InStr(1, CurItem, Rng.Offset(0, 2).Value) = 0 Then
                    D.Item(TempStr).Item(CurKey) = D.Item(TempStr).Item(CurKey) & "；" & Rng.Offset(0, 2).Value
                End If
            End If
        End If
        Set Rng = Rng.Offset(1, 0)
        TempStr = ""
        CurKey = ""
        NewKey = ""
    Loop
    Set Rng = Range("G2")
    For i = 0 To D.Count - 1
        With Rng
            CurKey = Filter(D.keys, "")(i)
            .Offset(0, -1) = Split(CurKey, "#")(0)
            .Offset(0, 0) = Split(CurKey, "#")(1)
            .Offset(0, 1) = Filter(D.Item(CurKey).keys, "")(0)
            .Offset(0, 2) = Filter(D.Item(CurKey).items, "")(0)
            Set Rng = Rng.Offset(1, 0)
        End With
    Next
End Sub

如以上回答内容为低俗、色情、不良、暴力、侵权、涉及违法等信息，可以点下面链接进行举报！

点此我要举报以上问答信息