使用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的快捷方式。