求大神幫助 - 有關Word VBA 的問題

terenceli35

大家好，最近我打算寫一個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

1. <blockquote>Option Explicit

复制代码

不知道為什麼，"If oRng.Text = Arr Then" 形態總是不符合。

請問怎樣才能令 VBA 根據一個Excel 檔案中的名單複製一份Word 文件中的文字到另一個Excel 檔案？

小弟請求各位大神幫忙，感激萬分！

terenceli35

CODE在這裡，不知道為什麼原帖不能貼上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

batmanbbs

不会EXCEL，不过看上去Arr是个二维数组，不能直接和.text进行比较，需要加上索引（或者叫下标），比如Arr(0)(1) 【这个是WORD的写法】

terenceli35

batmanbbs 发表于 2023-4-20 12:40
不会EXCEL，不过看上去Arr是个二维数组，不能直接和.text进行比较，需要加上索引（或者叫下标），比如Arr(0 ...

可以示範一下嗎？不太明白。

batmanbbs

1.         Do While .Execute()
   
2.         
   
3.         If oRng.Text = Arr Then
   
4.                   WriteToWorksheet xlWB1, xlSheet, oRng.Text
   
5.             End If
   
6.         Loop

复制代码

你的代码中这段中的 oRng.Text = Arr ，其中Arr应该是一个二维数组，如果要比较，打个比方应该是 oRng.Text = Arr(0)(0) ，Arr(0)(0)代表二维数组中的第一个数据