Your Answer Pankaj Sonawane,
this appears to duplicate your last question. If I have missed some difference let me know. I will post the code here as well to make sure you see it.
I made a mock up of your two workbooks as I envision they are organized and tested this code. It acted as I expected - as I understand your requirement. Both procedures below need to be placed into your module. Test this on a copy of your workbook
Sub ABC() Dim bk1 As Workbook, bk2 As Workbook Dim sh1 As Worksheet, sh2 As Worksheet Dim r1 As Range, r2 As Range, r3 As Range Dim v As Variant, s As String, res As Variant Dim r4 As Range, r5 As Range, Aval As String Dim ii As Long, r6 As Range Dim bFound As Boolean, cell As Range ' Set a reference to "copy of Extract1.xls" Set bk1 = Workbooks("Copy of Extract1.xls") ' set a reference to Base Data in bk1 Set sh1 = bk1.Worksheets("Base Data") ' set a reference to all the cells in column E of sh1 ' starting in cell E2 Set r1 = sh1.Range("E2", sh1.Cells(sh1.Rows.Count, "E").End(xlUp)) ' set a reference to Copy of Mapping Details Set bk2 = Workbooks("Copy of Mapping Details.xls") ' loop through all the cells in column E of sh1 in bk1 ' starting in cell E2. If Only E2 needs to be checked, then ' change ' set r1 = sh1.Range("E2",sh1.cells(sh1.rows.count,"E").End(xlup)) ' to set r1 = Sh1.Range("E2") For Each cell In r1 ' extract the "x" you speak of ' first see if there is a comma in the cell; if so use split ' to separate out the "x". If not see if there is anything in ' the cell. If there is, that is "x", if not we will not search ' on that cell If InStr(1, cell, ",", vbTextCompare) > 0 Or Len(Trim(cell.Value)) > 0 Then If InStr(1, cell, ",", vbTextCompare) > 0 Then
v = Split(cell, ",") s = v(LBound(v))
ReDim v(0 To 0) v(0) = cell.Value s = cell.Value
End If For ii = LBound(v) To UBound(v)
s = v(ii) bFound = False ' Loop through the sheets in Bk2 in tab order ' search in column A for the "x" value held in the variable "s"
For Each sh2 In bk2.Worksheets
Set r2 = sh2.Range("A1", _ sh2.Cells(sh2.Rows.Count, "A").End(xlUp)) ' "*" & s & "*" finds the search string as a substring ' just s finds the search string as the complete cell ' entry. as written I am looking for a substring ' if this is not correct, change it to ' Application.countif(r2,s) If Application.CountIf(r2, "*" & s & "*") > 0 Then res = Application.Match("*" & s & "*", r2, 0) ' or res = Application.Match(s, r2, 0) If Not IsError(res) Then Set r3 = r2(res) bFound = True Exit For End If 'Not IsError(res) End If 'Application.CountIf(r2, "*" & s & "*") > 0 Next 'Each sh2 In bk2.Worksheets '5. If it is present, then do certain tasks 'which I will let you know in my next question.
If bFound Then ' code goes here to do certain tasks 'MsgBox s & " found at " & r3.Address(0, 0, xlA1, True) Set r4 = r3.Offset(0, 2) ' column C Do While r4.Row > 1 Set r4 = r4.Offset(-1, 0) If r4.Value = 1 Then Set r5 = r4.Offset(0, -2) Aval = r5.Value Set r6 = cell.Offset(0, -1) If InStr(1, r6, Aval, _ vbTextCompare) = 0 Then If IsEmpty(r6) Then r6.Value = Aval If InStr(1, cell, ",", vbTextCompare) > 0 Then r6.Font.ColorIndex = 3 End If Else ColorCell r6, Aval End If End If Exit Do Else ' a one was not found in column C End If Loop End If ' bfound = True
Next 'ii = LBound(v) To UBound(v) End If ' InStr(1, cell, ",", vbTextCompare) > 0 Then Next 'Each cell In r1 End Sub
Public Sub ColorCell(r As Range, Aval As String) Dim l As Long Dim s As String, vv As Variant l = Len(r) + Len(Aval) + 1 s = r.Value & "," & Aval ReDim vv(1 To l) For i = 1 To Len(r) vv(i) = r.Characters(i, 1).Font.ColorIndex Next For i = Len(r) + 2 To l
vv(i) = 3
Next r = s For i = 1 To l
r.Characters(i, 1).Font.ColorIndex = vv(i)
Next End Sub PS: If you didn't understand the answer, please post a followup with additional information or what your question is.
My New Question:
The above code is running without any error, however no actions are been taken in the sheet.
Can I send you the sheets which I am working on to your personal email?
based on your description of what you wanted, I build test files and ran the code against them. The code worked fine for me.
If you want to send your files, I will take a look. Don't expect a rapid response however as I will have to perform testing on the files.