「代码」（更新1）VBA操作Word表格：把运动员名单表按指定格式导出到Word文档

'Option ExplicitDim ws As Worksheet, wsData As Worksheet, rng As RangeDim lastRow As Integer, lastCol As IntegerDim saveFolder As String, filePath As String
Private Sub UserForm_Initialize()    For Each ws In ThisWorkbook.Sheets        If ws.Name = "名单表" Then            Me.CmbData.Text = ws.Name        End If    Next        For Each ws In ThisWorkbook.Sheets        If InStr(ws.Name, "名单表") > 0 Then            Me.CmbData.AddItem ws.Name        End If    Next    Me.TxbLineNumber = 4    Me.TxbSaveFolder = ThisWorkbook.Path    Me.TxbFileName = "代表队参赛情况表"    saveFolder = Me.TxbSaveFolder    End Sub
Private Sub CmbData_Change()    Set wsData = Nothing    On Error Resume Next    Set wsData = ThisWorkbook.Sheets(Me.CmbData.Text)    On Error GoTo 0    If wsData Is Nothing Then        MsgBox "无效工作表！请重新选择或输入！"        Exit Sub    End If    End Sub
Private Sub CmdChooseFolder_Click()    Dim preFolder As String    preFolder = Me.TxbSaveFolder    saveFolder = FolderSelected    If saveFolder = "" Then        saveFolder = preFolder    Else        Me.TxbSaveFolder = saveFolder    End IfEnd Sub
Private Sub CmdExit_Click()    Unload MeEnd Sub
Private Sub CmdToWord_Click()    Dim i As Long, j As Long    Dim wsTemp As Worksheet    Dim arr(), temp(), arrtemp(), arrKeys()    Dim dic As Object, dkey As String, dkey1, dkey2    Dim sports  As String    Dim Groups As Integer, Members As Integer, totalRows As Integer    Dim targetRow As Integer    Dim WordApp As Object    Dim doc As Object, tbl As Object, wdRange As Object    Dim iCol As Integer            If wsData Is Nothing Then        MsgBox "请选择或输入正确的数据表！"        Exit Sub    End If        iCol = Me.TxbLineNumber    If iCol = 0 Then        MsgBox "每列人数不能为0"        Exit Sub    End If    If Not IsFolderExists(saveFolder) Then                MsgBox "保存文件夹错误，请重新选择！"        Exit Sub    End If            filePath = saveFolder & "\" & Me.TxbFileName & ".docx"        '//处理人员名单    wsData.Copy after:=wsData    Set wsTemp = ActiveSheet    Set dic = CreateObject("Scripting.Dictionary")    With wsTemp        '.Name = "temp" & Int(Rnd * 10000)        lastRow = .UsedRange.Rows.Count        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column                Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))        Call SortRange(rng, .Columns(1), True)        arr = rng.Value        For i = 2 To lastRow            If arr(i, 1) <> "" Then                dkey1 = arr(i, 4)   '//代表队                dkey2 = arr(i, 1)                If Not dic.exists(dkey1) Then                    dic.Add dkey1, CreateObject("Scripting.Dictionary")                End If                If dkey2 = "领队" Or dkey2 = "教练" Then                    If Not dic(dkey1).exists("领队") Then                        dic(dkey1)("领队") = dkey2 & ":" & arr(i, 2)                    Else                        If dkey2 = "领队" Then                            dic(dkey1)("领队") = dkey2 & ":" & arr(i, 2) & Space(4) & dic(dkey1)("领队")                        Else                            dic(dkey1)("领队") = dic(dkey1)("领队") & Space(4) & dkey2 & ":" & arr(i, 2)                        End If                    End If                Else                    dic(dkey1)("人员") = dic(dkey1)("人员") & "|" & arr(i, 1) & Space(2) & arr(i, 2)                    If Me.CheckBox1 Then                        sports = ""                        For j = 5 To lastCol                            If arr(i, j) <> "" Then                                sports = sports & arr(1, j) & "、"                            End If                        Next                        If sports <> "" Then                            sports = Left(sports, Len(sports) - 1)                        End If                        dic(dkey1)("人员") = dic(dkey1)("人员") & ":" & sports                                            End If                End If                            End If        Next        Application.DisplayAlerts = False        .Delete        Application.DisplayAlerts = True    End With        ''//处理领队教练    '    'Set wsTemp = ThisWorkbook.Sheets("领队")    'With wsTemp    'lastRow = .UsedRange.Rows.Count    'lastCol = .UsedRange.Columns.Count    '    'Set rng = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))    'arr = rng.Value    'For i = 2 To lastRow    'If arr(i, 1) <> "" Then    'dkey1 = arr(i, 1)   '//代表队    'If Not dic.exists(dkey1) Then    'dic.Add dkey1, CreateObject("Scripting.Dictionary")    '    'End If    'For j = 2 To lastCol    'If arr(i, j) <> "" Then    'dic(dkey1)("领队") = dic(dkey1)("领队") & arr(1, j) & "：" & arr(i, j) & Space(4)    'End If    '    'Next    '    'End If    'Next    'End With            Call WriteToWord(dic, iCol, filePath)    MsgBox "导出完成！"        Unload Me        End Sub
Private Sub WriteToWord(dic As Object, iCol As Integer, filePath As String)    Dim WordApp As Object    Dim WordDoc As Object    Dim WordRange As Object    Dim dkey1 As Variant, dkey2 As Variant    Dim temp() As String, teamLeader As String, strMember As String    Dim i As Long, j As Long    Dim iRow As Integer, totalRow As Integer    Dim currRow As Integer, currCol As Integer    Application.ScreenUpdating = False    On Error Resume Next    Set WordApp = GetObject(class:="Word.Application")    If WordApp Is Nothing Then        Set WordApp = CreateObject(class:="Word.Application")    End If    On Error GoTo 0        WordApp.Visible = True        Set WordDoc = WordApp.Documents.Add        With WordDoc        .PageSetup.LeftMargin = Application.CentimetersToPoints(2.54)        .PageSetup.RightMargin = Application.CentimetersToPoints(2.54)        .PageSetup.TopMargin = Application.CentimetersToPoints(2.54)        .PageSetup.BottomMargin = Application.CentimetersToPoints(2.54)    End With            '在文档开头插入标题    Set WordRange = WordDoc.Range    With WordRange        .Collapse Direction:=0        .Text = "各代表队参赛运动员名单"        '.Style = WordDoc.Styles("标题 1")        .ParagraphFormat.Alignment = 1 ' 居中对齐        .Font.Name = "宋体"        .Font.Bold = True        .Font.Size = 16        .ParagraphFormat.SpaceBefore = 1 ' 段前间距        .ParagraphFormat.SpaceAfter = 1 ' 段后间距        .InsertParagraphAfter        .InsertParagraphAfter    End With                '遍历字典并写入Word文档    For Each dkey1 In dic.Keys        '大标题        Set WordRange = WordDoc.Range(WordDoc.Content.End - 1, WordDoc.Content.End)        With WordRange            .ParagraphFormat.Alignment = wdAlignParagraphLeft            .ParagraphFormat.SpaceBefore = 10 ' 段前间距            .ParagraphFormat.SpaceAfter = 1 ' 段后间距            .Collapse Direction:=0            .Text = dkey1            .Font.Name = "宋体"            .Font.Size = 12'            .Font.Bold = True            .InsertParagraphAfter        End With                teamLeader = dic(dkey1)("领队")        Set WordRange = WordDoc.Range(WordDoc.Content.End - 1, WordDoc.Content.End)        With WordRange            .ParagraphFormat.Alignment = wdAlignParagraphLeft            .Collapse Direction:=0            .ParagraphFormat.SpaceBefore = 5 ' 段前间距            .ParagraphFormat.SpaceAfter = 5 ' 段后间距            .Text = teamLeader            .Font.Name = "宋体"            .Font.Size = 12'            .Font.Bold = True        End With        strMember = dic(dkey1)("人员")        If Left(strMember, 1) = "|" Then            strMember = Mid(strMember, 2)        End If        If Right(strMember, 1) = "|" Then            strMember = Left(strMember, Len(strMember) - 1)        End If        temp = Split(strMember, "|")                Set WordRange = WordDoc.Range(WordDoc.Content.End - 1, WordDoc.Content.End)        With WordRange            .ParagraphFormat.Alignment = wdAlignParagraphLeft            .Font.Size = 12            .Font.Name = "宋体"            .Collapse Direction:=0        End With        Dim tbl As Object                totalRow = Application.WorksheetFunction.RoundUp((UBound(temp) + 1) / iCol, 0)                Set tbl = WordDoc.Tables.Add(WordRange, totalRow, iCol)        For Each Row In tbl.Rows            Row.AllowBreakAcrossPages = False        Next        currCol = 0        For j = 1 To totalRow            For i = 1 To iCol                currCol = currCol + 1                If currCol > UBound(temp) + 1 Then Exit For                tbl.Cell(j, i).Range.Text = temp(currCol - 1)                Application.StatusBar = "正在写入：" & dkey1 & "|" & temp(currCol - 1)                            Next        Next            Next        Dim isOpen As Boolean    For Each doc In WordApp.Documents        '如果找到同名的文档        If doc.FullName = filePath Then            isOpen = True            Exit For        End If    Next    If isOpen Then        MsgBox "已存在同名文件，请自行另存！"    Else        Application.DisplayAlerts = False        WordDoc.SaveAs2 filePath        Application.DisplayAlerts = True    End If        Application.ScreenUpdating = True    '清理对象    Set tbl = Nothing    Set WordDoc = Nothing    Set WordApp = Nothing    Application.StatusBar = ""End Sub