使用VBA从excel获取数据到办公室字阵列

Question

我有一个excel文件，其中存储了一些文本和关键字列。

我想使用Excel中的数据在Word中使用vba进行一些高级搜索。但是，我试图将excel单元格中的数据转换为vba单词中的数组时出错。

我已经使用了转置excel函数，但它不能处理超过255个字符，因此我无法获取超过255个字符的单元格值。

如果有人能帮我一把，我会很感激。

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

更改此：

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

要：

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

然后在您的循环：

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代码中的Byte和Long更换。 Ctrl+H是Replace的快捷方式。