Holen Sie sich Daten von Excel zu Office-Word-Array mit VBA

Question

Ich habe eine Excel-Datei, wo in Spalten einige Text und Schlüsselwörter gespeichert sind.

Ich möchte die Daten in Excel verwenden, um einige erweiterte Suche in Word mit VBA zu machen. Aber ich bekomme einen Fehler beim Versuch, die Daten von Excel-Zellen zu einem Array in VBA Word zu transponieren.

Ich habe die transpose Excel-Funktion verwendet, aber es behandelt nicht mehr als 255 Zeichen, so kann ich nicht Zelle Wert erhalten, der 255 Zeichen überschreitet.

Ich wäre dankbar, wenn mir jemand helfen könnte.

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

Wechsel:

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

An:

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

Dann in der Schleife:

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

Suhce für Byte in Ihrem Code und ersetzen Sie es durch Long. Ctrl+H ist die Abkürzung für Replace. diese