字母表相同的A列分配

Piano青墨

有2个相同的班分配例如。想分配的结果，怎么用VBA编写，请帮忙看看，非常感谢

taller

班级工作表缺少“学校”字段，例如二班有两个不同学校，两表关联时，将产生重复记录，一个同学有两行记录

shiruiqiang

看lz的模拟结果，就是根据学校重复提取

shiruiqiang

usedrange

参与一下...

gwjkkkkk

Option Explicit
Sub test1()
    Dim ar, br(), strResult$(), i&, j&, k&, m&, n&, p&, r&
   
    Application.ScreenUpdating = False
   
    ReDim strResult(1 To 10 ^ 4, 1 To 6)
    With Worksheets(2).[A1].CurrentRegion
        p = 2
        ar = .Resize(.Rows.Count + 1)
        For i = 2 To UBound(ar) - 1
            If ar(i + 1, 1) <> ar(p, 1) Then
                r = r + 1
                ReDim Preserve br(1 To r)
                br(r) = Range(.Cells(p, 1), .Cells(i, 1)).Resize(, 6).Value '.Interior.ColorIndex = n
                For k = 1 To UBound(br(r))
                    For j = 2 To 3
                        br(r)(k, j + 3) = br(r)(k, j)
                    Next j
                Next k
                p = i + 1
            End If
        Next i
    End With
   
    r = 0
    ar = Worksheets(1).[A1].CurrentRegion.Value
    For i = 1 To UBound(ar)
        For j = 1 To UBound(br)
            If br(j)(1, 1) = ar(i, 1) Then
               
                For m = 1 To UBound(br(j))
                    r = r + 1
                    For n = 1 To UBound(br(j), 2)
                        strResult(r, n) = br(j)(m, n)
                    Next n
                    For n = 2 To 4
                        strResult(r, n) = ar(i, n)
                    Next n
                Next m
            End If
        Next j
    Next i
   
    With Worksheets(3)
        .[A1].CurrentRegion.Offset(1).Clear
        .[A2].Resize(r, UBound(strResult, 2)) = strResult
        .Activate
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。