Macro help required

Last Edited By Krjb Donovan
Last Updated: Mar 05, 2014 09:45 PM GMT

Question

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

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