|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 terenceli35 于 2023-4-19 17:41 编辑
大家好，最近我打算寫一個Word VBA ，根據一個Excel 檔案中的名單，複製一份Word 文件中的文字到另一個Excel 檔案。
步驟如下：
1. 運行宏(Macro)，首先彈出視窗，選擇要貼上複製文字的Excel 檔案。
2. 宏(Macro) 會在已打開的文件中，按一個Excel 檔案中的名單，複製Word 文件中的文字。
3. 在步驟1選擇的Excel 檔案貼上複製文字。
4. 彈出複製的Excel 檔案。
以下是暫時的code:
Option Explicit
Private xlWB1 As String
Private xlWB2 As String
Private xlSheet As String
Sub CopyText_from_Word_to_Excel()
Dim EXL As Object
Dim xlsWB1 As Object
Dim xlsWB2 As Object
Dim xlsPath As String
Dim oDoc As Document
Dim oRng As Range
Dim Arr() As Variant
xlsWB1 = "D:\databases\ENG.xlsx"
xlWB2 = BrowseForFile("Select Workbook", True)
If Not xlWB2 = vbNullString Then
xlSheet = "sheet1"
Set EXL = CreateObject("Excel.Application")
Set oDoc = ActiveDocument
Set oRng = oDoc.Range
Arr = xlFillArray(xlWB1, xlSheet)
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Name = "Times New Roman"
.Font.Bold = True
Do While .Execute()
If oRng.Text = Arr Then
WriteToWorksheet xlWB1, xlSheet, oRng.Text
End If
Loop
End With
lbl_Exit:
Exit Sub
End If
Set xlsWB2 = EXL.Workbooks.Open(xlWB2)
EXL.Visible = True
End Sub
Private Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
Dim fDialog As FileDialog
On Error GoTo err_Handler
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.Title = strTitle
.AllowMultiSelect = False
.Filters.Clear
If bExcel Then
.Filters.Add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
Else
.Filters.Add "Word documents", "*.doc,*.docx,*.docm"
End If
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_Handler:
BrowseForFile = fDialog.SelectedItems.item(1)
End With
lbl_Exit:
Exit Function
err_Handler:
BrowseForFile = vbNullString
Resume lbl_Exit
End Function
Private Function xlFillArray(strWorkbook As String, _
strRange As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long
strRange = strRange & "$]" 'Use this to work with a named worksheet
'strRange = strRange & "]" 'Use this to work with a named range
Set CN = CreateObject("ADODB.Connection")
'Set HDR=NO for no header row
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"""
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strRange, CN, 2, 1
With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
- <blockquote>Option Explicit
不知道為什麼，"If oRng.Text = Arr Then" 形態總是不符合。
請問怎樣才能令 VBA 根據一個Excel 檔案中的名單複製一份Word 文件中的文字到另一個Excel 檔案？
小弟請求各位大神幫忙，感激萬分！
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-4-19 17:37
楼主