Macro help required

Question

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))

Else

 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?

Pankaj

Answer

Pankaj Sonawane,

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.