求助：通过excel控制定位word文档

iceberg1973

word里面有每个人的表，电子表格是名单，我需要在点击excel里面的身份证号码，然后word就跳转到对应人的表格上，并且把这张word表格以表格里面的人名单独保存为一个个的word文档
而且word文档里面的表格需要批量调整大小，让每一张表格都在一页纸上




附件上传了示例

duquancai

为啥要用Excel来控制？话说附件word文档打开也有问题，还有这种需求，对于我来说没有兴趣，所以我不想浪费时间。你等其他有兴趣的大神解决。我帮你顶！d=====(￣▽￣*)b

duquancai

还是给你写一个，附件，打开Excel文件，点击身份证号码！！！

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.    Dim rng As Range, s$, fso As New FileSystemObject, pf$, i As Object
   
3.    Dim wdapp As Object, Docx As Object, rg As Object
   
4.    Dim odoc As Object
   
5.    Set rng = Sheet1.Range("a1:a" & Sheet1.Cells(Rows.Count, 1).End(3).Row)
   
6.    If rng.Count = 1 Then MsgBox "没有身份证号码哦！": Exit Sub
   
7.    If Intersect(rng, Target) Is Nothing Then
   
8.       MsgBox "说好了的点身份证，点其它干嘛呢？": Exit Sub
   
9.    Else
   
10.       s = Target.Value
    
11.    End If
    
12.    pf = ThisWorkbook.Path & "\登记表.doc"
    
13.    If fso.FileExists(ThisWorkbook.Path & "" & s & ".doc") Then MsgBox "已经有这个文件了,别再点了！": Exit Sub
    
14.    Set wdapp = CreateObject("Word.Application")
    
15.    wdapp.Visible = False
    
16.    Set Docx = wdapp.Documents.Open(pf, Visible:=True)
    
17.    With CreateObject("VBScript.Regexp")
    
18.       .Pattern = s
    
19.       For Each i In Docx.Paragraphs
    
20.          For Each mt In .Execute(i.Range)
    
21.             m = mt.FirstIndex: n = mt.Length
    
22.             Set rg = Docx.Range(i.Range.Start + m, i.Range.Start + m + n)
    
23.          Next
    
24.       Next
    
25.    End With
    
26.    If Not rg.Information(12) Then MsgBox "文档表格中无身份证号码！": GoTo 100
    
27.    rg.Expand 15: rg.Copy
    
28.    Set odoc = wdapp.Documents.Add
    
29.    odoc.Content.Paste
    
30.    odoc.SaveAs ThisWorkbook.Path & "" & s & ".doc"
    
31.    odoc.Close
    
32. 100      Docx.Close
    
33.    wdapp.Quit
    
34.    MsgBox "操作完毕！"
    
35. End Sub

复制代码