使用VBA从Excel到Office Word数组获取数据

Question

I have an excel file where are stored in columns some text and keywords.

I want to use the data in excel to make some Advanced search in Word using vba. But I'm getting an error trying to transpose the data from excel cells to an array in vba word.

I have used the transpose excel function but it doesn't handle more than 255 characters so I can't get cell's value that exceeds 255 characters.

I would be thankfull if someone could give me a hand.

Option Explicit
    Dim strArray
    Dim range As range
    Dim i As Long
    Dim numberOfUniqMatches As Integer
    Dim totalMatches As Integer

Sub HighlightMatchesAndSummarize()
    totalMatches = 0
    '************************************ GET DATA FROM EXCEL ***************************************
    Dim xlApp As Object
    Dim xlBook As Object
    Const strWorkBookName As String = "D:\keyword_source_3.xlsx"
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlBook = xlApp.Workbooks.Open(FileName:=strWorkBookName)
    'xlApp.Visible = True
    xlApp.Visible = False
    'transpose excel cells in our arrays
    strArray = xlApp.Transpose(xlApp.ActiveSheet.range("A1:A20" & AlRow).Value)
    Set xlBook = Nothing
    xlApp.Quit
    Set xlApp = Nothing
    '
    ' End of data extraction

    '/******************************** SEARCH LOOP START **********************************
    For i = 1 To UBound(strArray)
        numberOfUniqMatches = 0
        Set range = ActiveDocument.range

        With range.Find
        .Text = strArray(i)
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchFuzzy = False
        .MatchPhrase = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False
            Do While .Execute(Forward:=True) = True
                    numberOfUniqMatches = numberOfUniqMatches + 1
                    totalMatches = totalMatches + 1
                    range.HighlightColorIndex = wdYellow
            Loop
        End With
    Next
    '
    ' End of search loop

    ' Display message if no matching word is found
    If totalMatches <= 0 Then
        MsgBox "Sorry! No matching keyword found."
    Else
        MsgBox "Search ended: " & totalMatches & " matching word(s)."
    End If

End Sub

Answer 1

Change this:

strArray = xlApp.Transpose(xlApp.ActiveSheet.range("A1:A20" & AlRow).Value)

To:

'remove the transpose (and fix the range...)
strArray = xlApp.ActiveSheet.range("A1:A" & AlRow).Value

Then in your loop:

For i = 1 To UBound(strArray, 1) '<<<<<<<
    numberOfUniqMatches = 0
    Set range = ActiveDocument.range

    With range.Find
    .Text = strArray(i, 1) '<<<<<<<
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchFuzzy = False
    .MatchPhrase = True
    .MatchSoundsLike = False
    .MatchAllWordForms = False
        Do While .Execute(Forward:=True) = True
                numberOfUniqMatches = numberOfUniqMatches + 1
                totalMatches = totalMatches + 1
                range.HighlightColorIndex = wdYellow
        Loop
    End With
Next

Answer 2

Saerch for Byte in your code and replace it by Long . Ctrl+H is the shortcut for Replace .