VBA实例：一键生成会议座位牌

Sub getAllName()    '//一百以内的加减法 @公众号【Excel小火箭】    '// 2024-06-27 By Sdx孙大侠    Dim sht As Worksheet    Dim rng As Range, c As Range    Dim d2, d3, d4, d5, d6    Dim i As Integer    Dim lastRow As Long        Dim sht2 As Worksheet    Dim sht3 As Worksheet    Dim sht4 As Worksheet    Dim sht5 As Worksheet    Dim sht6 As Worksheet        Application.ScreenUpdating = False        Set sht = Worksheets("操作界面")    Set sht2 = Worksheets("二个字")    Set sht3 = Worksheets("三个字")    Set sht4 = Worksheets("四个字")    Set sht5 = Worksheets("五个字")    Set sht6 = Worksheets("五个字以上")        lngRow = getLastRow(sht)        Set rng = sht.Range("A1:J" & lngRow)
    Set d2 = CreateObject("Scripting.Dictionary")    Set d3 = CreateObject("Scripting.Dictionary")    Set d4 = CreateObject("Scripting.Dictionary")    Set d5 = CreateObject("Scripting.Dictionary")    Set d6 = CreateObject("Scripting.Dictionary")        i = 1    For Each c In rng        Rem 数据清洗        c.Value = Replace(c.Value, Chr(10), "")        c.Value = Replace(c.Value, Space(1), "")        c.Value = Replace(c.Value, Space(2), "")        c.Value = Replace(c.Value, Space(3), "")        c.Value = Replace(c.Value, Space(4), "")                If Len(c.Value) = 2 Then d2(i) = c.Value        If Len(c.Value) = 3 Then d3(i) = c.Value        If Len(c.Value) = 4 Then d4(i) = c.Value        If Len(c.Value) = 5 Then d5(i) = c.Value        If Len(c.Value) = 6 Then d6(i) = c.Value                i = i + 1    Next        Rem 数据读取写入        Call getNamesToSht(sht2, d2)    Call getNamesToSht(sht3, d3)    Call getNamesToSht(sht4, d4)    Call getNamesToSht(sht5, d5)    Call getNamesToSht(sht6, d6)        Call GetFormatSht(sht2)    Call GetFormatSht(sht3)    Call GetFormatSht(sht4)    Call GetFormatSht(sht5)    Call GetFormatSht(sht6)        d2.RemoveAll    d3.RemoveAll    d4.RemoveAll    d5.RemoveAll    d6.RemoveAll        Set sht = Nothing    Set sht2 = Nothing    Set sht3 = Nothing    Set sht4 = Nothing    Set sht5 = Nothing    Set sht6 = Nothing        Application.ScreenUpdating = TrueEnd Sub
Sub getNamesToSht(sht As Worksheet, d)'// 2024-06-27 适用于座次排列'// By Szl孙大侠@Excel小火箭    Dim arr            Dim numRow As Long    Dim numCol As Long       Dim numRows As Long, numCols As Long    numRows = (d.Count / 2) + 1    numCols = 2       Dim cellRow As Long, cellCol As Long    Dim index As Long        index = 0        For cellRow = 1 To numRows        For cellCol = 1 To numCols            sht.Cells(cellRow, cellCol).Value = arr(index)            index = index + 1            If index > UBound(arr) + 1 Then                Exit For            End If        Next cellCol    Next cellRow    End Sub