简单的逻辑，关于数组和字典问题（可以付费）

zjzyj

Sub test()
    Dim arr, brr(1 To 10000, 1 To 7), ds1, ds2, x, m
    Set ds1 = CreateObject("Scripting.Dictionary")
    Set ds2 = CreateObject("Scripting.Dictionary")
    arr = Sheet1.[A1].CurrentRegion
    For m = 2 To UBound(arr)        '段落1信息装入字典ds1。起点、终点为关键字，其中起点的属性值为空，属性A1和A2赋值给终点
        ds1(arr(m, 1)) = "|" & "|"
        ds1(arr(m, 2)) = arr(m, 3) & "|" & arr(m, 4)
    Next
    arr = Sheet2.[A1].CurrentRegion
    For m = 2 To UBound(arr)      '段落2信息装入字典ds2，终点为关键字，属性B1、B2、B3为值
        ds2(arr(m, 2)) = arr(m, 3) & "|" & arr(m, 4) & "|" & arr(m, 5)
    Next
    x = 0
    m = 0
    While ds1.Count > 0 And ds2.Count > 0
        k1 = ds1.keys()(0)
        k2 = ds2.keys()(0)
        sp1 = Split(ds1(k1), "|")
        sp2 = Split(ds2(k2), "|")
        m = m + 1
        brr(m, 1) = x
        brr(m, 3) = sp1(0)
        brr(m, 4) = sp1(1)
        brr(m, 5) = sp2(0)
        brr(m, 6) = sp2(1)
        brr(m, 7) = sp2(2)
        If k1 < k2 Then
            x = k1
            ds1.Remove x
        End If
        If k2 < k1 Then
            x = k2
            ds2.Remove x
        End If
        If k1 = k2 Then
            x = k1
            ds1.Remove x
            ds2.Remove x
        End If
        brr(m, 2) = x
    Wend
    While ds1.Count > 0
        k1 = ds1.keys()(0)
        sp1 = Split(ds1(k1), "|")
        m = m + 1
        x = k1
        brr(m, 1) = x
        brr(m, 3) = sp1(0)
        brr(m, 4) = sp1(1)
        ds1.Remove x
    Wend
   
    While ds2.Count > 0
        k2 = ds2.keys()(0)
        sp2 = Split(ds2(k2), "|")
        m = m + 1
        x = k2
        brr(m, 1) = x
        brr(m, 5) = sp2(0)
        brr(m, 6) = sp2(1)
        brr(m, 7) = sp2(1)
        ds1.Remove x
    Wend
    Sheet4.[A2].Resize(m, 7) = brr
    Sheet4.Select

End Sub

zjzyj

Gaudi34

zjzyj 发表于 2021-1-16 12:44

谢谢您帮我解释。害，下次我也学习您这样的描述方式了，省的大家困惑，再次感谢您

笨鸟飞不高

路桩.zip (25.92 KB, 下载次数: 28)

2021-1-16 14:20 上传

点击文件名下载附件

xiangbaoan

，我全蒙错了……

zjzyj

把代码精减了一下：
Sub test()
    Dim arr, brr(1 To 10000, 1 To 7), ds1, ds2, i, m, x
    Set ds1 = CreateObject("Scripting.Dictionary")
    Set ds2 = CreateObject("Scripting.Dictionary")
    arr = Sheet1.[A1].CurrentRegion
    For m = 2 To UBound(arr)   '段落1信息装入字典ds1
        ds1(arr(m, 1)) = "|"   '以起点为关键字，值为空，"|"为分割标记符
        ds1(arr(m, 2)) = arr(m, 3) & "|" & arr(m, 4)    '以终点为关键字，值为属性A1 & A2
    Next
    arr = Sheet2.[A1].CurrentRegion
    For m = 2 To UBound(arr)      '段落2信息装入字典ds2。以终点作为关键字，值为属性B1 & B2 & B3
        ds2(arr(m, 2)) = arr(m, 3) & "|" & arr(m, 4) & "|" & arr(m, 5)
    Next
    x = 0:    m = 0
    While ds1.Count > 0 Or ds2.Count > 0
        m = m + 1:  brr(m, 1) = x
        If ds1.Count > 0 And ds2.Count > 0 Then  '当段落1和2都还没处理完时
            k1 = ds1.keys()(0):  k2 = ds2.keys()(0)   '从字典中各取出第一个关键字
            sp = Split(ds1(k1) & "|" & ds2(k2), "|")  '分割为5个值
            If k1 < k2 Then x = k1: ds1.Remove x      '把较小的那个干掉
            If k2 < k1 Then x = k2: ds2.Remove x
            If k1 = k2 Then x = k1: ds1.Remove x: ds2.Remove x   '当相同时，两个都干掉
        ElseIf ds1.Count > 0 Then      '当只剩段落1时
            k1 = ds1.keys()(0)
            sp = Split(ds1(k1) & "|||", "|")   '补足4个"｜"，分割为5个值
            x = k1
            ds1.Remove x
        ElseIf ds2.Count > 0 Then   '当只剩段落2时
            k2 = ds2.keys()(0)
            sp = Split("||" & ds2(k2), "|")
            x = k2
            ds2.Remove x
        End If
        
        brr(m, 2) = x
        For i = 0 To 4
            brr(m, i + 3) = sp(i)
        Next
    Wend
    Sheet1.[G2].Resize(m, 7) = brr
End Sub

Gaudi34

zjzyj 发表于 2021-1-16 15:50
把代码精减了一下：
Sub test()
    Dim arr, brr(1 To 10000, 1 To 7), ds1, ds2, i, m, x

老师您好，我突然发现一个问题，就是段落1和段落2的属性个数不定，可能是2,3个，也可能是4,5个，能否把这个情况也加入代码中呢？实在是抱歉，一开始没有意识到这个问题，麻烦您了

Gaudi34

笨鸟飞不高 发表于 2021-1-16 14:17

老师您好，我突然发现一个问题，就是段落1和段落2的属性个数不定，可能是2,3个，也可能是4,5个，能否把这个情况也加入代码中呢？实在是抱歉，一开始没有意识到这个问题，麻烦您了

笨鸟飞不高

Gaudi34 发表于 2021-1-16 22:34
老师您好，我突然发现一个问题，就是段落1和段落2的属性个数不定，可能是2,3个，也可能是4,5个，能否把这 ...

路桩.rar (29.69 KB, 下载次数: 5)

2021-1-17 12:23 上传

点击文件名下载附件

Gaudi34

笨鸟飞不高 发表于 2021-1-17 12:23

感谢老师，非常感谢您的帮助，解决了我的问题。我私信您了，加您好友了。之前说的付费咨询，我给您转过去一些，虽然不多，请您不要见笑。