Excel表格内容批量添加到多个word文档中

Dim docPath As String
    Dim wordApp As New Word.Application
    Dim wordDoc As New Word.Document
   
    Dim xlApp As New Excel.Application
    Dim xlBook As New Excel.Workbook
    Dim xlSheet As New Excel.Worksheet
   
    Dim xlConn As New ADODB.Connection
    Dim xlRs As New ADODB.Recordset
    Dim xlSql As String
    Dim strSheetName As String
   
   
Private Sub CmdSelectDic_Click()
 Unload Me
End Sub

Private Sub List_file(oPath As String)
   
          Dim uuFso, uuDir, uuFiles, uuObj
           
          List1.Clear
          Set uuFso = CreateObject("Scripting.FileSystemObject")
          Set uuDir = uuFso.getfolder(oPath)
          Set uuFiles = uuDir.Files
          For Each uuObj In uuFiles
                  Select Case UCase(uuFso.GetExtensionName(uuObj.Name))
                          Case "DOC"
                            If Left(uuObj.Name, 1) <> "~" Then
                                  List1.AddItem uuObj.Name
                            End If
                          Case Else
                  End Select
          Next
End Sub

Private Sub CmdExit_Click()
Unload Me
End Sub

Private Sub CmdSelectXL_Click()
    CommonDialog1.Filter = "Microsoft EXCEL(*.xls)|*.xls"
    CommonDialog1.InitDir = docPath
    CommonDialog1.ShowOpen
    lblXLName.Caption = CommonDialog1.FileName
End Sub

Private Sub CmdShowLog_Click()
   Shell "notepad " & App.Path & "/olog.log", vbNormalFocus
End Sub

Private Sub CmdStart_Click()
    Dim maxProcessbar
    Dim docNum
    docNum = 0
   
    If UCase(Right(Me.lblXLName.Caption, 3)) <> "XLS" Then
        MsgBox "请选择exlel数据表", vbInformation, "提示"
        Exit Sub
    End If
  
    CmdStart.Enabled = False
    CmdExit.Enabled = False
   
    Me.Caption = "正在处理..."
   
    '退出所以word文档 并保存
    wordApp.Quit True
   
    List2.Clear

    maxProcessbar = List1.ListCount
   
    '打开excel文件
   
    strName = Trim(lblXLName.Caption)
    
    xlConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & strName & ";Extended Properties='Excel 8.0;HDR=Yes'" '连接EXCEL文件
   
   
    '处理列表框中的每个doc文档
    While List1.ListCount
      
       docNum = docNum + 1

       Process_wordFile docPath & "/" & List1.List(0), CInt(docNum)
      
       List2.AddItem List1.List(0)
      
       List1.RemoveItem (0)
      
       Me.ProgressBar1.Value = 100 * docNum / maxProcessbar
      
       DoEvents
    Wend
   
    xlConn.Close
    Set xlConn = Nothing
   
    Me.Caption = "批量DOC文档处理"
    MsgBox "处理结束", vbInformation, "提示信息"
   
    CmdStart.Enabled = True
    CmdExit.Enabled = True
End Sub

Private Sub Process_wordFile(wfilePath As String, flwID As Integer)

    On Error Resume Next
  
    Dim newStr
    Dim useStyle
    Dim timeLimit
   
    Set wordApp = New Word.Application
    wordApp.Visible = False
   
    '打开word文档-
    Set wordDoc = wordApp.Documents.Open(wfilePath)
   
    '查询excel数据表
    Set xlRs = New ADODB.Recordset
   
    xlSql = "SELECT * FROM [" & strSheetName & "$] WHERE 证号 like '%" & RegExpNum(wordDoc.Tables(1).Rows(1).Cells(1).Range.Text) & "%'"
   
    xlRs.Open xlSql, xlConn, 1, 3
   
   
    useStyle = xlRs.Fields("类型")
    timeLimit = xlRs.Fields("期限")
   
    xlRs.Close
    Set xlRs = Nothing
   
   
    '图幅编号赋值
    newStr = Trim(TxtDM.Text)
    newStr = newStr & "-" & Mid(wordDoc.Tables(1).Rows(1).Cells(1).Range.Text, 6, 2)
    newStr = newStr & "-" & Left("0000", 4 - Len(CStr(flwID))) & flwID
    'wordDoc.Tables(1).Rows(4).Cells(2).Range.Text = newStr ' 岱山
    wordDoc.Tables(1).Rows(3).Cells(2).Range.Text = newStr '其它区县
   
    '调查表编号赋值
    'wordDoc.Tables(1).Rows(3).Cells(6).Range.Text = newStr & "B"   ' 岱山
    wordDoc.Tables(1).Rows(3).Cells(6).Range.Text = newStr & "B" '其它区县
   
    '修改面积
    newStr = wordDoc.Tables(1).Rows(5).Cells(4).Range.Text
    newStr = Left(newStr, Len(newStr) - 3)

    If IsNumeric(newStr) = True Then
        newStr = CDbl(newStr) / 15      '亩转换为公顷
        newStr = Round(newStr, 3)
        newStr = Format(newStr, "###0.0##")
        wordDoc.Tables(1).Rows(5).Cells(4).Range.Text = newStr & "公顷"
    End If

    newStr = wordDoc.Tables(1).Rows(6).Cells(4).Range.Text
    newStr = Left(newStr, Len(newStr) - 3)

    If IsNumeric(newStr) = True Then
        newStr = CDbl(newStr) / 15
        newStr = Round(newStr, 3)
        newStr = Format(newStr, "###0.0##")
        wordDoc.Tables(1).Rows(6).Cells(4).Range.Text = newStr & "公顷"
    End If

    '修改 实使用类型

    wordDoc.Tables(1).Rows(5).Cells(2).Range.Text = useStyle
    wordDoc.Tables(1).Rows(6).Cells(2).Range.Text = useStyle
   
    '设置 发证机关
    If TxtFZJG.Text <> "" Then
        wordDoc.Tables(1).Rows(7).Cells(4).Range.Text = TxtFZJG.Text
    End If
   
    '修改 年限
   
    wordDoc.Tables(1).Rows(7).Cells(6).Range.Text = timeLimit
   
   
   
    '修改 是否复核区划
     wordDoc.Tables(1).Rows(9).Cells(4).Range.Text = " 是√  否 "
   
    '修改整个表格内字体颜色
    wordDoc.Tables(1).Range.Font.Color = wdColorBlack
   
   
    '处理结束
    wordDoc.Close True
    wordApp.Quit
    Set wordApp = Nothing
    Set wordDoc = Nothing
   
    If Err.Number <> 0 Then
        writeLog (xlSql & vbCrLf & "usesytle=" & useStyle & "处理文件：" & wfilePath & "时，发生错误文件，对应的excel：" & lblXLName.Caption & vbCr & "错误编号:" & Err.Number & "错误描述:" & Err.Description)
    End If
End Sub

Private Sub Dir1_Change()
     Dim strs
     docPath = Dir1.Path
     List_file (docPath)
     Me.lblXLName.Caption = docPath
    
     '目录名和excel内表格的名字对应
     strs = Split(docPath, "/")
     strSheetName = strs(UBound(strs))
    
End Sub

Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
End Sub

Private Sub Form_Load()
    docPath = "C:"
    List_file (docPath)
End Sub

Function RegExpNum(s As String) As String
          Dim p     As String
         
          Dim reg     As RegExp
          Dim mc     As MatchCollection
          Dim m     As Match
          p = "([/d]{9})"
           
          Set reg = New RegExp
          reg.Pattern = p
          Set mc = reg.Execute(s)
         
          For Each m In mc
                  p = m.Value
          Next m
        '  MsgBox "mc.Count=" & mc.Count
         
          RegExpNum = p
          Set mc = Nothing
           
          Set reg = Nothing
End Function

Private Sub writeLog(str As String)
    str = Now() & "  " & str
     
    str = str & vbCrLf & "--------------------" & vbCr
   
    Open App.Path & "/olog.log" For Append As #1
    Write #1, str
    Close #1
End Sub