search combination of words in worksheet using VBA - vba

Question

I need to find the row which as combination of words (Keyword - Column 1 , keyword 2 - column 2 , keyword 3 - column 3) of sheet1 with sheet 2 which as more than 800 rows and 275 columns.
I have done a coding but it gives a result as "not responding". Please help me to sort out this issue.
below is the coding:-
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
Edit: More details
I have a workbook with two worksheets
Sheet 1 is having “N” number of data with 807 rows and 277 column
Sheet 2 is having the standard keyword combination (201 combinations) set.
Note: - each combination from sheet 2 can be available in any of the row or columns of sheet 1, But combination match should be in row wise alone.
Requirements: - Need to find the keyword combination from sheet 2 in sheet 1 once the combination found in sheet 1 we need to fetch the output.
Sheet 1 (Data Sheet)
Sheet 2 (Keyword Sheet)
Searching keywords from sheet 2 in sheet 1
keywords can find in many cells of sheet 1 (Yellow highlighted) but the combination will be find in only one row and we need to find that row (Green highlighted)
once we have found the row in sheet 1 which has the combination we need to fetch the fourth value from the last combination word and paste it in the 10th column of sheet 2.
E.g
in sheet 1
we have found the combination 100th row
in that row keyword 1 in (100,20)
keyword 2 in (100,40)
keyword 3 in (100,60)
then output should be need to copy the value from cell (100,64) in sheet 1 then need to paste in 10th column of sheet 2 to respective combination row of sheet 2.

Answer 1

This identifies Sheet2 rows in Sheet1, based on the first 3 columns as keywords
Once a record is found, it copies value from the 3rd col in Sheet1 in the 10th column of 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
.
Test Sheet 1
Test Sheet 2
Sheet1 Rows: 1,001, Cols: 501; Sheet2 Rows: 1,001, Cols: 501 - Time: 0.023 sec
New info:
Row 1 - Keyword 1 , keyword 2 , keyword 3 (once we find the row with
this order then we need to fetch the 4th value from keyword 3 in the
same row) and paste in 10 column of sheet 2