如何写一个宏命令，按一个Excel名单复制Word文件内的文字，然后在选定的Excel 贴上

terenceli35

大家好，请问如何写一个宏命令，按一个Excel名单复制Word文件内的文字，然后在选定的Excel 贴上？

例如在一个Word文件中，有以下对话：

陈大文：大家好，我是陈大文
李小明：请坐。
陈大文：好的。
陈月：好的。
李小明：请用1分钟介绍一下自己。
陈大文：我是陈大文，毕业于XXX......
陈月：我是陈月，毕业于XXX......

我希望写一个宏命令，做到以下的步骤：

1. 选取指定的Excel档案。
(以下两组代码可做到弹出视窗，让用家选取指定的Excel档案)

1. Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
   
2. Dim fDialog As FileDialog
   
3.     On Error GoTo err_Handler
   
4.     Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
   
5.     With fDialog
   
6.         .Title = strTitle
   
7.         .AllowMultiSelect = False
   
8.         .Filters.Clear
   
9.         If bExcel Then
   
10.             .Filters.add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
    
11.         Else
    
12.             .Filters.add "Word documents", "*.doc,*.docx,*.docm"
    
13.         End If
    
14.         .InitialView = msoFileDialogViewList
    
15.         If .Show <> -1 Then GoTo err_Handler:
    
16.         BrowseForFile = fDialog.SelectedItems.Item(1)
    
17.     End With
    
18. lbl_Exit:
    
19.     Exit Function
    
20. err_Handler:
    
21.     BrowseForFile = vbNullString
    
22.     Resume lbl_Exit
    
23. End Function

复制代码

1. Private strWorkbook As String
   
2. Private strSheet As String
   
3. 
   
4. strWorkbook = BrowseForFile("Select Workbook", True)
   
5. If Not strWorkbook = vbNullString Then
   
6. 
   
7. strSheet = "sheet1"

复制代码

2. 自动复制上述对话中的粗体字，字型是"新细明体"。
3. 自动在刚才选定的Excel 档案由Cell B3开始贴上。



我暂时只有以下的Macro，该Macro只能自动复制 "Speaker 1", "Speaker 2", "Speaker 3" 到指定的Excel 档案。

1. Option Explicit
   
2. 
   
3. Private Const xlWB As String = "C:\Path\Empty Excel File name.xlsx"
   
4. Private Const xlSheet As String = "Sheet1"
   
5. 
   
6. Sub ExtractText()
   
7. Dim oDoc As Document
   
8. Dim oRng As Range
   
9.     Set oDoc = ActiveDocument
   
10.     Set oRng = oDoc.Range
    
11.     With oRng.Find
    
12.         .ClearFormatting
    
13.         .Replacement.ClearFormatting
    
14.         .Font.Name = "Times New Roman"
    
15.         .Font.Bold = True
    
16.         Do While .Execute()
    
17.             If oRng.Text Like "Speaker*" Then
    
18.                 WriteToWorksheet xlWB, xlSheet, oRng.Text
    
19.             End If
    
20.         Loop
    
21.     End With
    
22. lbl_Exit:
    
23.     Exit Sub
    
24. End Sub
    
25. 
    
26. Private Function WriteToWorksheet(strWorkbook As String, _
    
27.                                   strRange As String, _
    
28.                                   strValues As String)
    
29. Dim ConnectionString As String
    
30. Dim strSQL As String
    
31. Dim CN As Object
    
32.     ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    
33.                        "Data Source=" & strWorkbook & ";" & _
    
34.                        "Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
    
35.     strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
    
36.     Set CN = CreateObject("ADODB.Connection")
    
37.     Call CN.Open(ConnectionString)
    
38.     Call CN.Execute(strSQL, , 1 Or 128)
    
39.     CN.Close
    
40.     Set CN = Nothing
    
41. lbl_Exit:
    
42.     Exit Function
    
43. End Function

复制代码

请问有大师可以帮助小弟吗？感激万分