Excel VBA批量排座

花了三个小时，做了一个自动排坐的程序和模板，自动匹配排座。效果如下图

原始数据

座位模板

生成效果

源码：

Option Explicit

Type typData

    NianJi As String

    BanJi As String

    XueHao As String

    XingMing As String

    ShiShiHao As String

    ZuoWeiHao As Integer

    WeiZhi As String

End Type

Sub ExamRoom()

    Dim i As Integer

    Dim j As Integer

    Dim r(1 To 64) As Integer

    Dim c(1 To 64) As Integer

    Dim DataStr() As typData

    Dim d As Object

'    Dim Loc() As String

'    Dim MaxNum() As Integer

    Dim Loc

    Dim MaxNum

    Dim LocCount As Integer

    Dim cnt As Integer

    Dim Has As Boolean

    Dim rng As Range

    Dim wb As Workbook

    Dim osht As Worksheet

    Dim sht As Worksheet

    LocCount = 0

    Set osht = ActiveSheet

    For i = 1 To 64

        For Each rng In Worksheets("64人").UsedRange

            If rng.Value = "空座" & i Then

                r(i) = rng.Row

                c(i) = rng.Column

            End If

        Next rng

    Next i

    Set d = CreateObject("scripting.dictionary")

    cnt = Cells(65536, 1).End(xlUp).Row - 2

    ReDim DataStr(0 To cnt)

    ReDim MaxNum(0 To 0)

    ReDim Loc(0 To 0)

    For i = 1 To cnt

        DataStr(i).NianJi = Cells(i + 2, 1)

        DataStr(i).BanJi = Cells(i + 2, 2)

        DataStr(i).XueHao = Cells(i + 2, 3)

        DataStr(i).XingMing = Cells(i + 2, 4)

        DataStr(i).ShiShiHao = Cells(i + 2, 6)

        DataStr(i).ZuoWeiHao = Cells(i + 2, 7)

        DataStr(i).WeiZhi = Cells(i + 2, 8)

        d(DataStr(i).WeiZhi) = d(DataStr(i).WeiZhi) + 1

'        Has = False

'        For j = 0 To UBound(Loc)

'            If Loc(j) = DataStr(i).WeiZhi Then

'                MaxNum(j) = MaxNum(j) + 1

'                Has = True

'                Exit For

'            End If

'        Next j

'        If Has = False Then

'            ReDim Preserve Loc(0 To UBound(Loc))

'            ReDim Preserve MaxNum(0 To UBound(MaxNum))

'            Loc(UBound(Loc)) = DataStr(i).WeiZhi

'            MaxNum(UBound(MaxNum)) = 1

'        End If

    Next i

    Loc = d.keys

    MaxNum = d.items

    Sheets(Array("40人", "48人", "56人", "64人")).Copy

    Set wb = ActiveWorkbook

    wb.Worksheets("40人").Range("3:3,7:7,11:11,15:15,19:19,23:23,27:27,31:31").ClearContents

    wb.Worksheets("48人").Range("3:3,7:7,11:11,15:15,19:19,23:23,27:27,31:31").ClearContents

    wb.Worksheets("56人").Range("3:3,7:7,11:11,15:15,19:19,23:23,27:27,31:31").ClearContents

    wb.Worksheets("64人").Range("3:3,7:7,11:11,15:15,19:19,23:23,27:27,31:31").ClearContents

    For i = 0 To UBound(Loc)

        If MaxNum(i) <= 40 Then

            wb.Sheets("40人").Copy After:=Sheets(Sheets.Count)

            ActiveSheet.Name = Loc(i)

        End If

        If MaxNum(i) <= 48 And MaxNum(i) > 40 Then

            wb.Sheets("48人").Copy After:=Sheets(Sheets.Count)

            ActiveSheet.Name = Loc(i)

        End If

        If MaxNum(i) <= 56 And MaxNum(i) > 48 Then

            wb.Sheets("56人").Copy After:=Sheets(Sheets.Count)

            ActiveSheet.Name = Loc(i)

        End If

        If MaxNum(i) <= 64 And MaxNum(i) > 56 Then

            wb.Sheets("64人").Copy After:=Sheets(Sheets.Count)

            ActiveSheet.Name = Loc(i)

        End If

        If MaxNum(i) > 64 Then

            MsgBox Loc(i) & "安排学生数量超过64！"

            Exit Sub

        End If

    Next i

    For i = 1 To cnt

        wb.Worksheets(DataStr(i).WeiZhi).Cells(r(DataStr(i).ZuoWeiHao), c(DataStr(i).ZuoWeiHao)) = DataStr(i).XueHao & DataStr(i).XingMing

        If DataStr(i).ZuoWeiHao = 1 Then

            wb.Worksheets(DataStr(i).WeiZhi).Cells(1, 1) = "（" & DataStr(i).NianJi & "）年级第一次月考（" & Format(DataStr(i).ShiShiHao, "00") & "）试室"

        End If

    Next i

    Application.DisplayAlerts = False

    wb.Sheets(Array("40人", "48人", "56人", "64人")).Delete

    Application.DisplayAlerts = True

    MsgBox "输出完毕！"

End Sub