Fatal编程技术网
  • vba/
  • 使用VBA搜索工作表中的单词组合

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

vba excel performance

使用VBA搜索工作表中的单词组合,vba,excel,performance,Vba,Excel,Performance,我需要找到一行，它是sheet1和Sheet2的单词组合（关键字-第1列，关键字2-第2列，关键字3-第3列），其中Sheet2有800多行275列 我已经做了编码，但它给出的结果是“没有响应”。请帮我解决这个问题 以下是编码：- Private Sub CommandButton1_Click() Dim keyword As String Dim keyword1 As String Dim keyword2 As String Dim keyword3 As String Dim k A

我需要找到一行，它是sheet1和Sheet2的单词组合（关键字-第1列，关键字2-第2列，关键字3-第3列），其中Sheet2有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

Private子命令按钮1\u单击（）
Dim关键字作为字符串
Dim关键字1作为字符串
Dim关键字2作为字符串
Dim关键字3作为字符串
暗k一样长
将k1变暗为等长
Application.ScreenUpdating=False
Set XML=ThisWorkbook.Worksheets（“XML”）
设置rn=XML.UsedRange
k=rn.Rows.Count+rn.Row-1
Debug.Print（k）
对于i=1到k
k1=rn.Columns.Count+rn.Column-1
调试.打印（k1）
对于j=1到k1
cellAYvalue=XML.Cells（i，j）
对于a=2到261
匹配尝试=0
关键字_标志=False
关键字1_标志=错误
关键字2_标志=False
关键字3_标志=错误
关键字4_标志=错误
关键字5_标志=错误
关键字=修剪（UCase（此工作簿。工作表（“关键字”）。单元格（a，2）））
关键字1=Trim（UCase（ThisWorkbook.Worksheets（“关键字”）.Cells（a，3）））
关键字2=修剪（UCase（ThisWorkbook.Worksheets（“关键字”）.Cells（a，4）））
关键字3=Trim（UCase（ThisWorkbook.Worksheets（“关键字”）.Cells（a，5）））
关键字4=修剪（UCase（ThisWorkbook.Worksheets（“关键字”）.Cells（a，6）））
关键字5=修剪（UCase（ThisWorkbook.Worksheets（“关键字”）.Cells（a，7）））
如果关键字为“”，则
关键字_Flag=True:matchtrunt=matchtrunt+1
如果结束
如果关键字1“”，则
关键字1_Flag=True:matchtrunt=matchtrunt+1
如果结束
如果关键字2“”，则
关键字2_Flag=True:matchtrunt=matchtrunt+1
如果结束
如果关键字为3“”，则
关键字3_Flag=True:matchtrunt=matchtrunt+1
如果结束
如果关键字4“”，则
关键字4_Flag=True:matchtrunt=matchtrunt+1
如果结束
如果关键字为5“”，则
关键字5_Flag=True:matchtrunt=matchtrunt+1
如果结束
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（“关键字”）.Cells（a，1）））
如果EXITloop=“”，则
退出
如果结束
匹配完成=错误
如果关键字_Flag=True，则
如果关键字=描述，则
MatchedCount=MatchedCount+1
如果matchtrunt=MatchedCount，则MatchComplete=True
如果结束
如果结束
如果关键字_Flag1=True，则
如果关键字1=说明1，则
MatchedCount=MatchedCount+1
如果matchtrunt=MatchedCount，则MatchComplete=True
如果结束
如果结束
如果关键字_Flag2=True，则
如果关键字2=说明2，则
MatchedCount=MatchedCount+1
如果matchtrunt=MatchedCount，则MatchComplete=True
如果结束
如果结束
如果关键字_Flag3=True，则
如果关键字3=说明3，则
MatchedCount=MatchedCount+1
如果matchtrunt=MatchedCount，则MatchComplete=True
如果结束
如果结束
如果关键字_Flag4=True，则
如果关键字4=描述4，则
MatchedCount=MatchedCount+1
如果matchtrunt=MatchedCount，则MatchComplete=True
如果结束
如果结束
如果关键字_Flag5=True，则
如果关键字5=说明5，则
MatchedCount=MatchedCount+1
如果matchtrunt=MatchedCount，则MatchComplete=True
如果结束
如果结束
inin=Trim（UCase（ThisWorkbook.Worksheets（“XML”）.Cells（i，112）））
ouou=Trim（UCase（此工作簿。工作表（“关键字”）。单元格（a，8）））
如果MatchComplete=True，则
ouou=inin
如果结束
a=a+0
下一个
j=j+0
下一个
i=i+0
下一个
Application.ScreenUpdating=True
MsgBox“已完成”
端接头
编辑：更多详细信息

我有一本有两张工作表的工作簿

第1页有“N”个数据，807行277列

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

注：-表2中的每个组合可在表1的任何行或列中使用，但组合匹配应仅在行中进行

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

第1页（数据表）

表2（关键字表）

在第1页的第2页中搜索关键字

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

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

例如

第1页

我们找到了第100排的组合

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

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

这根据第一行确定
Sheet1
中的
Sheet2
行 
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