Problem with line (row) in a macro

**k0st4din** · 03-18-2014, 10:21 AM

Hello friends, I wrote in two forums but second week no one can help me with my problem and just one line in the macro. There is something that needs to change for things to happen but I do not know what and how to change it. I would be very grateful if you assist me by your side.

Thanks to colleague (who helped me a lot and I am grateful to him) make a macro that I do a great job, but I have a problem I can not handle.
With this macro search from a database of all matching words and returns the result in the selected column and adds matches with plus sign (+) -> word1+word2+word3.......... or result = ?
But there's a problem, because if the words are too similar macro I added each match and shows wrong result.
QUIN200 -> RESULT=10, QUIN200PR -> result=15
sim20 -> RESULT=8, sim10 -> result=5
If I'm looking for word such as: (QUIN200) and (SIM20)
And in the database have close similar words
QUIN200
QUIN200PR
SIM20
SIM10
....
ect
I've selected column and the appropriate box should I return this result: 10+8
But now I return a result that is wrong, because obviously evidence from macro should I order something to change: 10+15+8+5

Code:

Sub Terapia()  
Dim X As Long, Cell As Range, CellText As String, ws As Worksheet 
  Dim Words As Variant, Replacements As Variant
  Const TableSheetName As String = "Sheet1"
  Application.Volatile
  Words = Sheets(TableSheetName).Range("AH2", Sheets(TableSheetName).Cells(Rows.Count, "AH").End(xlUp))
    Replacements = Sheets(TableSheetName).Range("AI2", Sheets(TableSheetName).Cells(Rows.Count, "AI").End(xlUp))
    For Each ws In Worksheets
    For Each Cell In ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp))
    CellText = ""
      For X = 1 To UBound(Words)
        If InStr(1, Cell.Value, Words(X, 1), vbTextCompare) Then CellText = CellText & "+" & Replacements(X, 1) ' Here is my problem
      Next
      Cell.Offset(, 4).Value = Mid(CellText, 2) 
    Next
  Next
End Sub

Again with the assistance of a colleague changed this line in the macro:

Code:

If InStr(1, Cell.Value, Words(X, 1), vbTextCompare) Then CellText = CellText & "+" & Replacements(X, 1)

with this:

Code:

If Cell.Value = Words(X, 1) Then CellText = CellText & "+" & Replacements(X, 1)

but now I have another problem (with this modified line) is exactly what I'm looking for, but if a row has more than one word, I do not add the next (or the result).
attach an image to grasp the idea:
Link image

**Admin** · 03-19-2014, 07:59 AM

Hi

not sure about this...

Code:

Option Explicit

Sub Terapia()

    Dim X As Long, Cell As Range, CellText As String, ws As Worksheet
    Dim Words As Variant, Replacements As Variant, k, i As Long
    
    Const TableSheetName As String = "Sheet1"
    Application.Volatile
    
    Words = Sheets(TableSheetName).Range("AH2", Sheets(TableSheetName).Cells(Rows.Count, "AH").End(xlUp))
    Replacements = Sheets(TableSheetName).Range("AI2", Sheets(TableSheetName).Cells(Rows.Count, "AI").End(xlUp))
    For Each ws In Worksheets
        For Each Cell In ws.Range("J2", ws.Cells(Rows.Count, "J").End(xlUp))
            k = Split(Cell.Value, ",") '<<<< adjust the delimiter
            CellText = ""
            For i = 0 To UBound(k)
                For X = 1 To UBound(Words)
                    If Trim(k(i)) = Words(X, 1) Then CellText = CellText & "+" & Replacements(X, 1)
                Next
            Next
            Cell.Offset(, 4).Value = Mid(CellText, 2)
        Next
    Next
    
End Sub