Question

我需要找到sheet1的单词组合（关键字 - 第1列，关键字2 - 第2列，关键字3 - 第3列）和第2页的行，其中包含超过800行和275列。

我已经完成了编码，但它给出的结果为＆＃34;没有响应＆＃34;。请帮我解决这个问题。

以下是编码： -

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的任何行或列中使用，但组合匹配应该仅在行中。

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

第1页（数据表）

第2页（关键字表）

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

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

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

E.g

第1页

我们找到了第100行的组合

在该行中关键字1（100,20）关键字2 in（100,40）关键字3（100,60）

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

Answer 1

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

找到记录后，它会复制Sheet1第10列Sheet2中第3列的值

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个值同一行）并粘贴在10页的第2页
中

使用VBA

1 个答案: