[已解决]对照排序VBA代码改写

图不安兔

各位老师：晚上好！麻烦将附件里“Transpose”去掉，谢谢！

最佳答案

月排行榜 / 总排行榜

哥儿-

2022-11-14 19:39

你源代码也没有对这个进行处理……
Sub test()
    Dim vArr, brr, crr, drr, i&, j&, n&, k
    Dim dic  As Object
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        vArr = .Range("l2").CurrentRegion
        brr = .Range("A2").CurrentRegion
    End With
    For i = 2 To UBound(vArr)
        dic(vArr(i, 1)) = i
    Next i
    ReDim crr(1 To UBound(brr), 1 To UBound(vArr, 2))
    For i = 3 To UBound(brr)
        If dic.exists(brr(i, 1)) Then
            For j = 1 To UBound(vArr, 2)
                crr(i - 2, j) = vArr(dic(brr(i, 1)), j)
            Next j
            dic.Remove brr(i, 1)
        End If
    Next
    ReDim drr(1 To UBound(vArr), 1 To UBound(vArr, 2))
    For Each k In dic.keys
        n = n + 1
        For j = 1 To UBound(vArr, 2)
            drr(n, j) = vArr(dic(k), j)
        Next
    Next k
    With Sheet1
        With .[l3].Resize(UBound(crr), UBound(crr, 2))
            .Clear
            .Value = crr
        End With
        .Cells(UBound(brr) + 1, "l").Resize(UBound(drr), UBound(drr, 2)).Value = drr
    End With
   
End Sub

跳转到最佳答案楼层

哥儿-

Sub test()
    Dim vArr, brr, crr, i&, j&
    Dim dic  As Object
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        vArr = .Range("l2").CurrentRegion
        brr = .Range("A2").CurrentRegion
    End With
    For i = 2 To UBound(vArr)
        dic(vArr(i, 1)) = i
    Next i
    ReDim crr(1 To UBound(brr), 1 To UBound(vArr, 2))
    For i = 3 To UBound(brr)
        If dic.exists(brr(i, 1)) Then
            For j = 1 To UBound(vArr, 2)
                crr(i - 2, j) = vArr(dic(brr(i, 1)), j)
            Next j
        End If
    Next
    With Sheet1.[l3].Resize(UBound(crr), UBound(crr, 2))
        .Clear
        .Value = crr
    End With
End Sub

图不安兔

哥儿- 发表于 2022-11-13 20:22
Sub test()
    Dim vArr, brr, crr, i&, j&
    Dim dic  As Object

衷心谢谢您，哥儿老师！漏掉了“?生小江”的信息，也就是如果对照不上的，也要，即没有参照的人的信息用VBA代码提取放在最后边，麻烦您修改一下，多谢！

哥儿-

图不安兔 发表于 2022-11-14 06:51
衷心谢谢您，哥儿老师！漏掉了“?生小江”的信息，也就是如果对照不上的，也要，即没有参照的人的信息用V ...

看不懂你想表达的意思……

图不安兔

哥儿- 发表于 2022-11-14 09:40
看不懂你想表达的意思……

哥儿老师：您好！非常抱歉没及时回复您，请海涵。您的代码就欠如图的要不补上，劳烦修改一下，多谢！

图不安兔

哥儿- 发表于 2022-11-14 09:40
看不懂你想表达的意思……

哥儿老师：用代码将着黄色的信息放在最后边，因为它与右边“姓名”列里的对应不上，所以放在最后边。我故意将“?生小江”比照“生小江”多了一个问号，对照不上。也就是不管以后有多少对照不上的都依次放在最后边。辛苦您修改一下，多谢！

哥儿-

你源代码也没有对这个进行处理……
Sub test()
    Dim vArr, brr, crr, drr, i&, j&, n&, k
    Dim dic  As Object
    Set dic = CreateObject("scripting.dictionary")
    With Sheet1
        vArr = .Range("l2").CurrentRegion
        brr = .Range("A2").CurrentRegion
    End With
    For i = 2 To UBound(vArr)
        dic(vArr(i, 1)) = i
    Next i
    ReDim crr(1 To UBound(brr), 1 To UBound(vArr, 2))
    For i = 3 To UBound(brr)
        If dic.exists(brr(i, 1)) Then
            For j = 1 To UBound(vArr, 2)
                crr(i - 2, j) = vArr(dic(brr(i, 1)), j)
            Next j
            dic.Remove brr(i, 1)
        End If
    Next
    ReDim drr(1 To UBound(vArr), 1 To UBound(vArr, 2))
    For Each k In dic.keys
        n = n + 1
        For j = 1 To UBound(vArr, 2)
            drr(n, j) = vArr(dic(k), j)
        Next
    Next k
    With Sheet1
        With .[l3].Resize(UBound(crr), UBound(crr, 2))
            .Clear
            .Value = crr
        End With
        .Cells(UBound(brr) + 1, "l").Resize(UBound(drr), UBound(drr, 2)).Value = drr
    End With
   
End Sub

图不安兔

哥儿- 发表于 2022-11-14 19:39
你源代码也没有对这个进行处理……
Sub test()
    Dim vArr, brr, crr, drr, i&, j&, n&, k

衷心感谢您，哥儿老师！太完美了。谢谢！

shuikouzx

学习了啊，值得学习