VBA多条EXCEL记录写入到WORD文档中

要点提示：

1、批量EXCEL记录

2、WORD表格模板（一个WORD表格）

3、为每一条记录生成一个独立的WORD表格

Sub Excel2Word()
    Application.ScreenUpdating = False
    
    p = ThisWorkbook.Path & "/" '根目录路径
    
    Dim myWS As Worksheet
    
    Set myWS = ThisWorkbook.Sheets(1) '存有数据的表格
    
Const Loct As Integer = 10000  '定义常量

Dim iCount(Loct) As String, numCount(Loct) As String, nameCount(Loct) As String, postCount(Loct) As String

Dim strColum As String, fDate As String, fMonth As String, fDay As String

Dim modeFilse As String

Dim j As Integer, i As Integer, Ct As Integer, postLen As Integer

strColum = ""

Ct = 0
    
    For j = 0 To Loct '统计数据记录总条数
        
        iCount(j) = Sheets("Sheet1").Range("B5").Offset(j, 0)

        If (Trim(iCount(j)) <> "") Then '检查B列数据是否为空，非空即统计
            numCount(j) = Sheets("Sheet1").Range("A5").Offset(j, 0)
            Ct = Ct + 1
            strColum = strColum & iCount(j) & ","
        End If
       
    Next j
    
    'MsgBox strColum & Ct

    'fDate = Format(Now(), "yyyy-mm-dd")
    

    modeFilse = p & "公司代表大会人员登记表.doc" 'WORD文档表格模板

    
    
    f = modeFilse '选择模板文件
    
    If (Ct > 0) Then
    
    For i = 5 To (Ct + 4) '遍历数据行数，EXCEL记录从第5行开始
    
        FileCopy f, p & "生成的文件/" & myWS.Cells(i, 1).Text & myWS.Cells(i, 2).Text & ".doc"  '复制空模板并以某列数据为名命名新产生的文档
        
        Set wd = CreateObject("word.application")
        
        Set d = wd.documents.Open(p & "生成的文件/" & myWS.Cells(i, 1).Text & myWS.Cells(i, 2).Text & ".doc") '打开新文档
        
        
        d.tables(1).Cell(1, 2) = myWS.Cells(i, 2).Text '写入姓名
        d.tables(1).Cell(1, 4) = myWS.Cells(i, 3).Text '性别
        d.tables(1).Cell(1, 6) = myWS.Cells(i, 4).Text  '出生年月
        
        d.tables(1).Cell(2, 2) = myWS.Cells(i, 5).Text '民族
        d.tables(1).Cell(2, 4) = myWS.Cells(i, 6).Text '籍贯
        d.tables(1).Cell(2, 6) = myWS.Cells(i, 8).Text  '党派
        
        d.tables(1).Cell(3, 2) = myWS.Cells(i, 17).Text
        d.tables(1).Cell(3, 4) = "广州"
        
        d.tables(1).Cell(4, 2) = "组织提名"
        d.tables(1).Cell(4, 4) = "健康"
        d.tables(1).Cell(4, 6) = myWS.Cells(i, 9).Text  '参加工作时间

        
        d.tables(1).Cell(5, 2) = myWS.Cells(i, 11).Text '职称
        d.tables(1).Cell(5, 4) = myWS.Cells(i, 13).Text '学历学位
        d.tables(1).Cell(5, 6) = ""  '所学专业
        d.tables(1).Cell(5, 8) = myWS.Cells(i, 12).Text  '个人特长
        
        d.tables(1).Cell(6, 2) = myWS.Cells(i, 16).Text  '毕业院校
        d.tables(1).Cell(6, 4) = myWS.Cells(i, 18).Text  '身份证号码
        
        d.tables(1).Cell(7, 2) = myWS.Cells(i, 19).Text  '所属结构
        
        d.tables(1).Cell(8, 2) = myWS.Cells(i, 22).Text  '电子信箱
        d.tables(1).Cell(8, 4) = ""  '微信号
        d.tables(1).Cell(9, 2) = myWS.Cells(i, 20).Text  '通讯地址
        d.tables(1).Cell(9, 4) = myWS.Cells(i, 26).Text  '手  机
        
        d.tables(1).Cell(10, 2) = myWS.Cells(i, 21).Text  '邮 编
        d.tables(1).Cell(10, 4) = myWS.Cells(i, 23).Text  '传真
        d.tables(1).Cell(10, 6) = myWS.Cells(i, 24).Text  '办公电话
        
        d.tables(1).Cell(11, 2) = myWS.Cells(i, 27).Text  '工作单位及现任（或原任）职务

        d.tables(1).Cell(12, 2) = myWS.Cells(i, 28).Text  '简历
        d.tables(1).Cell(13, 2) = myWS.Cells(i, 29).Text  '主要表现
        
        d.tables(1).Cell(14, 2) = myWS.Cells(i, 67).Text + myWS.Cells(i, 68).Text + myWS.Cells(i, 69).Text '选举结果
        
        d.tables(1).Cell(22, 2) = myWS.Cells(i, 30).Text  '现任或历任职务情况（地方、届次、任期起止时间）
        
        d.tables(1).Cell(23, 2) = ""  '备注
        
        
'***************家庭主要成员*******************

        d.tables(1).Cell(16, 2) = myWS.Cells(i, 31).Text  '称谓
        d.tables(1).Cell(16, 3) = myWS.Cells(i, 32).Text  '姓名
        d.tables(1).Cell(16, 4) = myWS.Cells(i, 33).Text  '出生年月
        d.tables(1).Cell(16, 5) = myWS.Cells(i, 34).Text  '政治面貌
        d.tables(1).Cell(16, 6) = myWS.Cells(i, 35).Text  '工作单位及职务
        d.tables(1).Cell(16, 7) = myWS.Cells(i, 35).Text  '是否取得外国国籍
        
        d.tables(1).Cell(17, 2) = myWS.Cells(i, 37).Text  '称谓
        d.tables(1).Cell(17, 3) = myWS.Cells(i, 38).Text  '姓名
        d.tables(1).Cell(17, 4) = myWS.Cells(i, 39).Text  '出生年月
        d.tables(1).Cell(17, 5) = myWS.Cells(i, 40).Text  '政治面貌
        d.tables(1).Cell(17, 6) = myWS.Cells(i, 41).Text  '工作单位及职务
        d.tables(1).Cell(17, 7) = myWS.Cells(i, 42).Text  '是否取得外国国籍
        
        d.tables(1).Cell(18, 2) = myWS.Cells(i, 43).Text  '称谓
        d.tables(1).Cell(18, 3) = myWS.Cells(i, 44).Text  '姓名
        d.tables(1).Cell(18, 4) = myWS.Cells(i, 45).Text  '出生年月
        d.tables(1).Cell(18, 5) = myWS.Cells(i, 46).Text  '政治面貌
        d.tables(1).Cell(18, 6) = myWS.Cells(i, 47).Text  '工作单位及职务
        d.tables(1).Cell(18, 7) = myWS.Cells(i, 48).Text  '是否取得外国国籍
        
        
        d.tables(1).Cell(19, 2) = myWS.Cells(i, 49).Text  '称谓
        d.tables(1).Cell(19, 3) = myWS.Cells(i, 50).Text  '姓名
        d.tables(1).Cell(19, 4) = myWS.Cells(i, 51).Text  '出生年月
        d.tables(1).Cell(19, 5) = myWS.Cells(i, 52).Text  '政治面貌
        d.tables(1).Cell(19, 6) = myWS.Cells(i, 53).Text  '工作单位及职务
        d.tables(1).Cell(19, 7) = myWS.Cells(i, 54).Text  '是否取得外国国籍
        
        
        d.tables(1).Cell(20, 2) = myWS.Cells(i, 55).Text  '称谓
        d.tables(1).Cell(20, 3) = myWS.Cells(i, 56).Text  '姓名
        d.tables(1).Cell(20, 4) = myWS.Cells(i, 57).Text  '出生年月
        d.tables(1).Cell(20, 5) = myWS.Cells(i, 58).Text  '政治面貌
        d.tables(1).Cell(20, 6) = myWS.Cells(i, 59).Text  '工作单位及职务
        d.tables(1).Cell(20, 7) = myWS.Cells(i, 60).Text  '是否取得外国国籍
        
        
'***************家庭主要成员*******************

        
        d.Close
        
        wd.Quit
        
        Set wd = Nothing
        
    Next i

    Application.ScreenUpdating = True
    
    Else
    
    MsgBox "没有数据！"
    
    End If
    
    
End Sub