想要用VBA实现这种排序结果是否可以，谢谢！

feixiangye

AB列和DE列是两组数据，想要实现以A列和D列的名称一样的排序到同一行，两组行数不一样的放空，
最终想要如H  I列和K L列的结果，是否可以实现，谢谢！

cyh3230

这东西, 用SQL很方便, 用VBA 有点麻烦

沈默00

确实有点麻烦，行数定位会相互交叉递增，先看一下

笨鸟飞不高

排序.zip (16.46 KB, 下载次数: 25)

2023-10-19 16:09 上传

点击文件名下载附件

凑一个！

3190496160

Sub 排序()
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:b" & r)
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    br = .Range("d1:e" & rs)
    For i = 2 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            d(Trim(ar(i, 1))) = ""
        End If
    Next i
    For i = 2 To UBound(br)
        If Trim(br(i, 1)) <> "" Then
            d(Trim(br(i, 1))) = ""
        End If
    Next i
    For Each k In d.keys
        m = m + 1
        n = 0
        ReDim arr(1 To UBound(ar), 1 To 2)
        For i = 2 To UBound(ar)
            If Trim(ar(i, 1)) = k Then
                n = n + 1
                For j = 1 To 2
                    arr(n, j) = ar(i, j)
                Next j
            End If
        Next i
        If n > 0 Then
            If m = 1 Then
                .Cells(2, 8).Resize(n, 2) = arr
            Else
                ms = .Cells(Rows.Count, 8).End(xlUp).Row + 1
                ws = .Cells(Rows.Count, 11).End(xlUp).Row + 1
                If ms >= ws Then
                    hs = ms
                Else
                    hs = ws
                End If
                .Cells(hs, 8).Resize(n, 2) = arr
            End If
        End If
        n = 0
        ReDim arr(1 To UBound(br), 1 To 2)
        For i = 2 To UBound(br)
            If Trim(br(i, 1)) = k Then
                n = n + 1
                For j = 1 To 2
                    arr(n, j) = br(i, j)
                Next j
            End If
        Next i
        If n > 0 Then
            If m = 1 Then
                .Cells(2, 11).Resize(n, 2) = arr
            Else
                hs = ""
                ms = .Cells(Rows.Count, 8).End(xlUp).Row
                For s = 2 To ms
                    If Trim(.Cells(s, 8)) = k Then
                        hs = s
                        Exit For
                    End If
                Next s
                If hs = "" Then
                    hs = ms
                Else
                    hs = hs
                End If
                .Cells(hs, 11).Resize(n, 2) = arr
            End If
        End If
    Next k
End With
MsgBox "ok!"
End Sub

3190496160

排序.rar (19.99 KB, 下载次数: 21)

2023-10-19 16:26 上传

点击文件名下载附件

铁马1980

凑个数





排序2.rar (16.66 KB, 下载次数: 15)

2023-10-19 18:08 上传

点击文件名下载附件

liulang0808

Sub test()
    Set da = CreateObject("Scripting.Dictionary")
    Set dd = CreateObject("Scripting.Dictionary")
    Arr = Range("A1").CurrentRegion
    Brr = Range("D1").CurrentRegion
    Application.ScreenUpdating = False
    For j = 2 To UBound(Arr)
        If da.exists(Arr(j, 1)) Then
            Set da(Arr(j, 1)) = Union(da(Arr(j, 1)), Cells(j, 1).Resize(1, 2))
        Else
            Set da(Arr(j, 1)) = Cells(j, 1).Resize(1, 2)
        End If
    Next j
    For j = 2 To UBound(Brr)
        If dd.exists(Brr(j, 1)) Then
            Set dd(Brr(j, 1)) = Union(dd(Brr(j, 1)), Cells(j, 4).Resize(1, 2))
        Else
            Set dd(Brr(j, 1)) = Cells(j, 4).Resize(1, 2)
        End If
    Next j
    For Each k In da.keys
        r = Cells(Rows.Count, 14).End(3).Row + 1
        If r <= Cells(Rows.Count, 17).End(3).Row Then r = Cells(Rows.Count, 17).End(3).Row + 1
        da(k).Copy Cells(r, 14)
        If dd.exists(k) Then
            dd(k).Copy Cells(r, 17)
            dd.Remove k
        End If
    Next k
    For Each k In dd.keys
        r = Cells(Rows.Count, 17).End(3).Row + 1
        dd(k).Copy Cells(r, 17)
    Next k
    Application.ScreenUpdating = True
End Sub

liulang0808

排序1.zip (16.99 KB, 下载次数: 10)

2023-10-19 20:06 上传

点击文件名下载附件

对应区域拷贝

chxw68

参与一下。