Intersect and Union

[u473]

I have a Workbook named "MyFile" in which Sheet1 contains a list of
topics
in Col. "D", a Keyword in Col. "A" and a SubKeyword in Col. "B"
..
From ThisWorkbook, I want to prompted for the Keyword and Subkeyword
to be searched
in MyFile Sheet1 and return the content of Col. "D" in ThisWorkbook.
The Subkeyword can be left blank if necessary, and more than one row
can be returned in ThisWorkbook.
Since I use a With -End With structure, my attempts to place dot
prefixes has been unsuccessful.
Help appreciated.
..
Sub FindKeys()
Dim WB1, WB2 As Workbook
Dim SH1, SH2 As Worksheet
Dim MyPath As String
Dim X As Long, Y As Long
Dim Joined As String, Answer As String, Found As String
Dim R As Range, SearchRange As Range, RowSlice As Range
Dim K1, K2 As String ' Keyword and Subkeyword to Search
MyPath = "C:\Work\"
Set WB1 = ThisWorkbook
Set WS1 = WB1.Worksheets("Sheet1")
Set WB2 = Workbooks.Open(MyPath & "MyFile.xls")
Set WS2 = WB2.Worksheets("Sheet1")
K1 = InputBox("Key 1", "Ok")
K2 = InputBox("Key 2", "Ok")
Y = 2
With WS2
Set SearchRange = Intersect(ActiveSheet.UsedRange, Union(Range("A:B"),
Columns("D")))
For X = 2 To SearchRange.Rows.Count
Set RowSlice = Intersect(Rows(X), SearchRange)
Joined = ""
For Each R In RowSlice
Joined = Joined & Chr(1) & R.Value
Next
If InStr(1, Joined, K1, vbTextCompare) > 0 And InStr(1, Joined, K2,
vbTextCompare) > 0 Then
Found = .Cells(X, 4).Value
With WS1
.Cells(Y, 1).Value = Found
Y = Y + 1
End With
End If
Next
End With
WS1.Cells(1, 1).Select ' Return to ThisWorkbook
End Sub

 

[Nick H]

Hi u473,

You would be doing yourself a huge favour if you always write Option
Explicit at the top of the module and only dimension one variable per
line.

The following works for me (beware line wrap)...

Sub FindKeys()
Dim WB2 As Workbook
Dim SH1 As Worksheet
Dim SH2 As Worksheet
Dim MyPath As String
Dim X As Long
Dim Y As Long
Dim Joined As String
Dim R As Range
Dim SearchRange As Range
Dim RowSlice As Range
Dim K1 As String ' Keyword to Search
Dim K2 As String ' Subkeyword to Search

MyPath = "C:\Work\"

Set SH1 = ThisWorkbook.Worksheets("Sheet1")
Set WB2 = Workbooks.Open(MyPath & "MyFile.xls")
Set SH2 = WB2.Worksheets("Sheet1")
K1 = InputBox("Key 1", "Ok")
K2 = InputBox("Key 2", "Ok")
Y = 2

With SH2
Set SearchRange = Intersect(.UsedRange,
Union(.Range("A:B"), .Columns("D")))
For X = 2 To SearchRange.Rows.Count
Set RowSlice = Intersect(Rows(X), SearchRange)
Joined = ""
For Each R In RowSlice
Joined = Joined & Chr(1) & R.Value
Next
If InStr(1, Joined, K1, vbTextCompare) > 0 Then
If InStr(1, Joined, K2, vbTextCompare) > 0 Then
SH1.Cells(Y, 1).Value = .Cells(X, 4).Value
Y = Y + 1
End If
End If
Next
End With

SH1.Activate ' Return to ThisWorkbook
SH1.Cells(1, 1).Activate
End Sub


Br, Nick.

 

[u473]

Thank you very much. I take note. It works