使用 VBA 在工作表中搜索单词组合

Question

我需要找到作为 sheet1 的单词组合（关键字 - 第 1 列，关键字 2 - 第 2 列，关键字 3 - 第 3 列）与表 2 超过 800 行和 275 列的行。

我已经完成了编码，但它给出的结果是“没有响应”。请帮我解决这个问题。

下面是代码：-

Private Sub CommandButton1_Click()

Dim keyword As String
Dim keyword1 As String
Dim keyword2 As String
Dim keyword3 As String
Dim k As Long
Dim k1 As Long

Application.ScreenUpdating = False


Set XML = ThisWorkbook.Worksheets("XML")
Set rn = XML.UsedRange

k = rn.Rows.Count + rn.Row - 1
Debug.Print (k)
For i = 1 To k

k1 = rn.Columns.Count + rn.Column - 1
Debug.Print (k1)
For j = 1 To k1

cellAYvalue = XML.Cells(i, j)

For a = 2 To 261

MatchAttempt = 0

keyword_Flag = False
keyword1_Flag = False
keyword2_Flag = False
keyword3_Flag = False
keyword4_Flag = False
keyword5_Flag = False

keyword = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 2)))
keyword1 = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 3)))
keyword2 = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 4)))
keyword3 = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 5)))
keyword4 = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 6)))
keyword5 = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 7)))

If keyword <> "" Then
    keyword_Flag = True: MatchAttempt = MatchAttempt + 1
End If
If keyword1 <> "" Then
    keyword1_Flag = True: MatchAttempt = MatchAttempt + 1
End If
If keyword2 <> "" Then
    keyword2_Flag = True: MatchAttempt = MatchAttempt + 1
End If
If keyword3 <> "" Then
    keyword3_Flag = True: MatchAttempt = MatchAttempt + 1
End If
If keyword4 <> "" Then
    keyword4_Flag = True: MatchAttempt = MatchAttempt + 1
End If
If keyword5 <> "" Then
    keyword5_Flag = True: MatchAttempt = MatchAttempt + 1
End If


        MatchedCount = 0

        Description = Trim(UCase(cellAYvalue = XML.Cells(i, j)))
        Description1 = Trim(UCase(cellAYvalue = XML.Cells(i, j)))
        Description2 = Trim(UCase(cellAYvalue = XML.Cells(i, j)))
        Description3 = Trim(UCase(cellAYvalue = XML.Cells(i, j)))
        Description4 = Trim(UCase(cellAYvalue = XML.Cells(i, j)))
        Description5 = Trim(UCase(cellAYvalue = XML.Cells(i, j)))
        EXITloop = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 1)))

        If EXITloop = "" Then
        Exit For
        End If


              MatchComplete = False

              If keyword_Flag = True Then
                If keyword = Description Then
                    MatchedCount = MatchedCount + 1
                    If MatchAttempt = MatchedCount Then MatchComplete = True
                End If
              End If
                If keyword_Flag1 = True Then
                If keyword1 = Description1 Then
                    MatchedCount = MatchedCount + 1
                    If MatchAttempt = MatchedCount Then MatchComplete = True
                End If
              End If
              If keyword_Flag2 = True Then
                If keyword2 = Description2 Then
                    MatchedCount = MatchedCount + 1
                    If MatchAttempt = MatchedCount Then MatchComplete = True
                End If
              End If
              If keyword_Flag3 = True Then
                If keyword3 = Description3 Then
                    MatchedCount = MatchedCount + 1
                    If MatchAttempt = MatchedCount Then MatchComplete = True
                End If
              End If
              If keyword_Flag4 = True Then
                If keyword4 = Description4 Then
                    MatchedCount = MatchedCount + 1
                    If MatchAttempt = MatchedCount Then MatchComplete = True
                End If
              End If
              If keyword_Flag5 = True Then
                If keyword5 = Description5 Then
                    MatchedCount = MatchedCount + 1
                    If MatchAttempt = MatchedCount Then MatchComplete = True
                End If
              End If


                inin = Trim(UCase(ThisWorkbook.Worksheets("XML").Cells(i, 112)))
                ouou = Trim(UCase(ThisWorkbook.Worksheets("Keyword").Cells(a, 8)))


            If MatchComplete = True Then

                    ouou = inin

            End If


a = a + 0

Next

j = j + 0

Next

i = i + 0

Next

Application.ScreenUpdating = True

MsgBox "Completed"

End Sub

---

编辑：更多细节

---

我有一个包含两个工作表的工作簿

工作表 1 包含“N”个数据，包含 807 行和 277 列

表 2 设置了标准关键字组合（201 个组合）。

注意：-工作表 2 中的每个组合都可以在工作表 1 的任何行或列中使用，但组合匹配应单独按行进行。

要求： - 需要从 sheet 1 中的 sheet 2 中找到关键字组合，一旦在 sheet 1 中找到组合，我们需要获取输出。

表 1（数据表）

表 2（关键字表）

在工作表 1 中的工作表 2 中搜索关键字

关键字可以在工作表 1 的许多单元格中找到（黄色突出显示），但组合只能在一行中找到，我们需要找到该行（绿色突出显示）

一旦我们在工作表 1 中找到具有组合的行，我们需要从最后一个组合词中获取第四个值并将其粘贴到工作表 2 的第 10 列。

例如

在第 1 页中

我们找到了第 100 行的组合

在该行关键字 1 in (100,20) (100,40) 中的关键字 2 关键字 3 in (100,60)

然后输出应该需要从表 1 中的单元格 (100,64) 中复制值，然后需要将表 2 的第 10 列粘贴到表 2 的相应组合行中。

Answer 1

这会根据前 3 列作为关键字识别 Sheet1 中的 Sheet2 行

一旦找到记录，它会从Sheet1 的第 3 列复制值，在Sheet2 的第 10 列中

---

Option Explicit

Private Sub CommandButton1_Click()

    Const FR = 2    'Start row
    Const KC = 3    'Last Keyword column
    Const TC = 10   'Target column

    Dim ws1 As Worksheet:   Set ws1 = Sheet1    'Or: ThisWorkbook.Worksheets("Sheet1")
    Dim ws2 As Worksheet:   Set ws2 = Sheet2

    Dim lr1 As Long:        lr1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
    Dim lr2 As Long:        lr2 = ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row

    Dim arr1 As Variant:    arr1 = ws1.Range(ws1.Cells(FR, 1), ws1.Cells(lr1, KC))
    Dim arr2 As Variant:    arr2 = ws2.Range(ws2.Cells(FR, 1), ws2.Cells(lr2, KC))

    Dim d1 As Object:       Set d1 = CreateObject("Scripting.Dictionary")
    Dim d2 As Object:       Set d2 = CreateObject("Scripting.Dictionary")
    Dim dr As Object:       Set dr = CreateObject("Scripting.Dictionary")   'Result

    LoadDictionary d1, arr1
    LoadDictionary d2, arr2
    GetKeywords d2, d1, dr

    Dim r As Long

    arr2 = ws2.Range(ws2.Cells(FR, 1), ws2.Cells(lr2, TC))
    If dr.Count > 0 Then
        For r = 1 To lr2
            If dr.Exists(r) Then arr2(r, TC) = arr2(r, KC)  'Or arr2(r, TC) = dr(r)
        Next
    End If
    ws2.Range(ws2.Cells(FR, 1), ws2.Cells(lr2, TC)) = arr2
End Sub

---

Private Sub LoadDictionary(ByRef d As Object, arr As Variant)   'Expects 2-d array

    Dim r As Long, c As Long, k As String

    For r = 1 To UBound(arr, 1)
        k = "|"
        For c = 1 To UBound(arr, 2)
            k = k & arr(r, c) & "|"     'Concatenate all columns
        Next
        d(k) = r
    Next
End Sub

Private Sub GetKeywords(ByRef d1 As Object, ByRef d2 As Object, ByRef dr As Object)

    Dim r As Long, k As String, arr As Variant

    For r = 0 To d1.Count - 1
        k = d1.Keys()(r)
        If d2.Exists(k) Then
            arr = Split(k, "|")
            dr(d1(k)) = arr(UBound(arr) - 1)
        End If
    Next
End Sub

---

.

测试Sheet 1

测试Sheet 2

---

Sheet1 Rows: 1,001, Cols: 501; Sheet2 Rows: 1,001, Cols: 501 - Time: 0.023 sec

新信息：

第 1 行 - 关键字 1 ，关键字 2 ，关键字 3 （一旦我们找到与 这个顺序然后我们需要从关键字 3 中获取第 4 个值 同一行）并粘贴到工作表 2 的 10 列中