Check if substring is found in range of strings

Hi!

Can anyone help with this?

I have a column with descriptions and one with amounts like:

A                                              B
Description                              Amount
FoodstoreA, Oslo, Norway      203,45
Food shopB, Bergen              123,45
DeliC                                        20
Shell Oslo                              102,80
Exxon                                      100,00

I would like to have lists in other columns like
AA                   AB
Food                Car Expenses
FoodstoreA     Shell
Food shopB     Exxon
DeliC               Gulf

etc.

and then in one adjacent column (C) have all the food amounts and another column (D) with all the car expenses etc.

like:

if value in column Description contains any of the substrings in the column Food, then show amount. Otherwise 0 or blank.

That would leave me with one column for food expenses and one for car expenses and I could go on with other types of expenses in separate columns.

Thanks for any help!

Brgds
IVer in Oslo
Iver Erling ArvaSenior consultantAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

[ fanpages ]IT Services ConsultantCommented:
Hi IVer in Oslo,

The following code is within the Public code module, "basQ_28259727", of the attached workbook.

Option Explicit
Public Sub Q_28259727()

' --------------------------------------------------------------------------------------------------------------
' [ http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28259727.html ]
'
' Question Channel: Experts Exchange > Software > Office / Productivity > Office Suites > MS Office > MS Excel
'
' ID:               Q_28259727
' Question Title:   Check if substring is found in range of strings
' Question Asker:   IverErling                                [ http://www.experts-exchange.com/M_6554677.html ]
' Question Dated:   2013-10-07 at 08:26:39
'
' Expert Comment:   fanpages                                   [ http://www.experts-exchange.com/M_258171.html ]
' Copyright:        (c) 2013 Clearlogic Concepts (UK) Limited    [ http://linkedin.com/in/ITServicesConsultant ]
' --------------------------------------------------------------------------------------------------------------

  Dim blnApplication_ScreenUpdating                     As Boolean
  Dim blnWend                                           As Boolean
  Dim intColumn                                         As Integer
  Dim lngErr_Number                                     As Long
  Dim lngLoop                                           As Long
  Dim lngRow                                            As Long
  Dim objADODB_Connection                               As Object
  Dim objADODB_Recordset                                As Object
  Dim objRange                                          As Range
  Dim strSQL                                            As String
  Dim strErr_Description                                As String
 
  On Error GoTo Err_Q_28259727
 
  blnApplication_ScreenUpdating = Application.ScreenUpdating
  Application.ScreenUpdating = False
  
  Set objRange = Range(Columns("AA"), _
                       Columns(Cells.Columns.Count).End(xlToLeft))
  
  Set objADODB_Connection = CreateObject("ADODB.Connection")
 
  objADODB_Connection.Provider = "Microsoft." & IIf(Val(Application.Version) <= 11#, "Jet.OLEDB.4.0", "ACE.OLEDB.12.0")
  objADODB_Connection.ConnectionString = "Data Source=" & ActiveWorkbook.FullName & ";Extended Properties=Excel " & _
                                          IIf(Val(Application.Version) <= 11#, "8", "12") & ".0;"
  
  objADODB_Connection.Open
 
  strSQL = ""
  strSQL = strSQL & "SELECT "
  strSQL = strSQL & "* "
  strSQL = strSQL & "FROM "
  strSQL = strSQL & "[EXCEL " & _
                     IIf(Val(Application.Version) <= 11#, "8", "12") & ".0;"                                                                            ' Note: Val(...) only recognizes a period ["."] as a valid decimal separator
  strSQL = strSQL & "IMEX=1;"
  strSQL = strSQL & "HDR=Yes;"
  strSQL = strSQL & "DATABASE=" & _
                    ActiveWorkbook.FullName & _
                    "].[" & _
                    ActiveSheet.Name & _
                    "$" & _
                    objRange.Address(RowAbsolute:=False, ColumnAbsolute:=False) & _
                    "] "
  
  Set objADODB_Recordset = CreateObject("ADODB.Recordset")
 
  objADODB_Recordset.CursorType = 3                                                                                                                     ' adOpenStatic
  objADODB_Recordset.CursorLocation = 3                                                                                                                 ' adUseClient
  objADODB_Recordset.ActiveConnection = objADODB_Connection
 
  objADODB_Recordset.Open (strSQL)
 
  If Not (objADODB_Recordset.EOF) Then
     objADODB_Recordset.MoveLast
     
     For intColumn = 3 To Columns("C").End(xlToRight).Column
         
         objADODB_Recordset.MoveFirst
      
         lngRow = Cells(Cells.Rows.Count, intColumn).End(xlUp).Row
         
         If lngRow >= 2& Then
            Range(Cells(2&, intColumn), Cells(lngRow, intColumn)).ClearContents
         End If ' If lngRow >= 2& Then
         
         lngRow = Cells(Cells.Rows.Count, "A").End(xlUp).Row
         
         For lngLoop = 0& To (objADODB_Recordset.Fields.Count - 1&)
         
             If objADODB_Recordset.Fields(lngLoop).Name = Cells(1&, intColumn).Value Then
                blnWend = (objADODB_Recordset.EOF)
                
                While Not (blnWend)
                
                    blnWend = (IsNull(objADODB_Recordset.Fields(lngLoop)))
                    
                    If Not (blnWend) Then
                       Set objRange = Range(Cells(2&, "A"), _
                                            Cells(lngRow, "A")).Find(What:=objADODB_Recordset.Fields(lngLoop), _
                                                                     LookAt:=xlPart)

                       If Not (objRange Is Nothing) Then
                          Cells(objRange.Row, intColumn) = Cells(objRange.Row, "B")
                          Cells(objRange.Row, intColumn).NumberFormat = Cells(objRange.Row, "B").NumberFormat
                       End If ' If Not (objRange Is Nothing) Then
                       
                       objADODB_Recordset.MoveNext
                    End If ' If Not (blnWend) Then
                    
                Wend
                
             End If ' If objADODB_Recordset.Fields(lngLoop).Name = Cells(1&, intColumn).Value Then
             
         Next lngLoop
         
    Next intColumn
  End If ' If Not (objADODB_Recordset.EOF) Then
  
Exit_Q_28259727:

  On Error Resume Next
 
  Set objRange = Nothing
  
  If Not (objADODB_Recordset Is Nothing) Then
     objADODB_Recordset.Close
     Set objADODB_Recordset = Nothing
  End If
 
  If Not (objADODB_Connection Is Nothing) Then
     objADODB_Connection.Close
     Set objADODB_Connection = Nothing
  End If

  Application.ScreenUpdating = blnApplication_ScreenUpdating
  
  Exit Sub
 
Err_Q_28259727:

  lngErr_Number = Err.Number
  strErr_Description = Err.Description
  
  On Error Resume Next
  
  Application.ScreenUpdating = True
  
  MsgBox "Error #" & CStr(lngErr_Number) & _
          vbCrLf & vbLf & _
          strErr_Description, _
          vbExclamation Or vbOKOnly, _
          ActiveWorkbook.Name
         
  Resume Exit_Q_28259727
 
End Sub

Open in new window



Please ensure you save this workbook to a physical location upon your local hard drive, rather than simply opening from your web browser (cache).

When you open the workbook, you will see that I have added some additional test data beyond that which you included in the question text.

I have also changed the column width of the columns [H:Y] just for the convenience of viewing the data content in columns [AA:AD].

Please use the [ALT]+[F8] key combination to display the "Macro" dialog box, select "Q_28259727" as the "Macro name", & click the [Run] button.

Thank you for your feedback when you have had the opportunity to review output generated.

BFN,

fp.
Q-28259727.xls
0
FaustulusCommented:
Please run the procedure 'SortToColumns' to see a demonstration of the code I wrote for you. Items that remain unidentified will be sorted into the "Other" column. Observe that "Oily Pickles" will go to the expense for Motoring. Note that the program will only process items not previously processed, but it will not find unprocessed items above an item that has been processed.
At the top of the code sheet you have an enum which you may have to set. You can adjust the row and columns to match your own worksheet design. NwsDate isn't used by the code. You may leave it out. In the enumeration it merely serves to specify NwsItem which IS used.
You can rename the two sheets as you like.
You can also name all your columns as you wish, including the "Other" column. The program identifies it by its number assigned in the Enum.
You can modify or add to the lists in the "Lists" sheet. However, you need to follow the rules set out on the "Instructions" tab. That tab can be deleted (or hidden). It isn't part of the program.
EXX-131007-Auto-ID-Accounts.xlsm
0
[ fanpages ]IT Services ConsultantCommented:
Faustulus: Did you miss the part of the question with these requirements?

I would like to have lists in other columns like
AA                   AB
Food                Car Expenses
FoodstoreA     Shell
Food shopB     Exxon
DeliC               Gulf

You seem to have created a second worksheet, [Lists], instead.
0
Big Business Goals? Which KPIs Will Help You

The most successful MSPs rely on metrics – known as key performance indicators (KPIs) – for making informed decisions that help their businesses thrive, rather than just survive. This eBook provides an overview of the most important KPIs used by top MSPs.

FaustulusCommented:
fanpages: I may have misunderstood the question but I programmed what I understood.

I understood that there is a list with expenses, 2 columns, one for description, the other for amount. The task is to separate the amounts into various columns so that all food expenses end up in the column for food expenses, expenses for the car in the column for transport etc. The lists in the second worksheet identify "McDonald" as a food expense but sorts "MacDonald" into "Other (unidentified)" expenses. So, "MacDonald" could be added to the list of key words for food to reduce the need for manual sorting next time around.
0
[ fanpages ]IT Services ConsultantCommented:
OK... but the question does clearly state where the individual category list strings are stored.
0
FaustulusCommented:
fanpages: Yes, indeed. But I took the definition of AA and AB as meaning "somewhere else". Should be better on a separate sheet which can be hidden or even VeryHidden.
0
Iver Erling ArvaSenior consultantAuthor Commented:
Dear friends, fanpages and Faustulus!

First, thank you very much for GREAT help! Both your solutions work great and illustrate in a good way that this can be done.

Second, this was just a sample to illustrate my "problem". Therefore, Faustulus is correct in assuming that AA and AB meant "somewhere else".

The actual case is a bank statement I download to Excel every month. I need to group the different expenses into separate categories. I have "sort of" solved this simply by adding formulas in the adjacent cells with a lot of if sentences, but thought that my limited knowledge of all the numerous Excel functions made my solution rather inefficient.
I never thought of making a program for it. I have actually programmed quite a lot in VB before, so looking into VBA is definitely an option, and I will study your code and use it as my introduction to VBA.

Again, thanks a lot for thorough and quick replies!

All the best from
IVer in Oslo, Norway.
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Iver Erling ArvaSenior consultantAuthor Commented:
I've requested that this question be closed as follows:

Accepted answer: 0 points for IverErling's comment #a39554722
Assisted answer: 250 points for fanpages's comment #a39551617
Assisted answer: 250 points for Faustulus's comment #a39551825

for the following reason:

I did not mark any of you as best solution since they both are great, and very different in the way they approach the problem. THe first one using SQL is very interesting indeed, and the second one splitting the sorting criteria data into a separate sheet and making an open-end solution so easy to expand is also very elegant. I would like to give you both a "Best solution" marker if I could!

Thanks again for truly great help!

IVer
0
FaustulusCommented:
It looks like IVer wants to assign points. Perhaps some one should help him with the procedure.
0
Iver Erling ArvaSenior consultantAuthor Commented:
Haven't I assigned 250 to each of you? The reason I'm in there is because that was the only way I found to not having to select a Best solution, if that is what you're asking.

All the best from
IVer
0
FaustulusCommented:
Yes, you have, and that is perfect!
I had a message in between which indicated your intention while at the same time setting the system on track to award yourself 0 points for solving the problem. I think the administrator also saw that note of yours and fixed it before my request to the same effect came to the top of the pile.
Have a great day!
Faustulus
0
Iver Erling ArvaSenior consultantAuthor Commented:
Dear Faustulus,

I have one question regarding your code. I spent some time with it yesterday and found that regardless of what column I pass to the LastRow function, it still returns the number of rows in the first column (or possibly the column with the most rows in it). E.g. when called from the ExpenseColumn function for column 2, it returns (in my case - my "real" Excel-sheet) 12 rows - which happens to be the number of columns in row 1 of the listsheet. Column 2 has like 5 rows. This results in an error later on when the ExpenseColumn function looks for a matching value in column 2 and comes to row 6 which contains nothing. Nothing matches all values and all data that doesn't have a match in column 1 is put in column 2. I have fixed this with a If check looking for blanks just above the If InStr(1,... statement in ExpenseColumn. Like this:
Private Function ExpenseColumn(LookIn As String) As Long
    
    Dim Ws As Worksheet
    Dim Rl As Long
    Dim R As Long, C As Long
    
    Dim S As String
    
    Set Ws = ThisWorkbook.Worksheets(ListSheet)
    C = 1
    Do While Len(Ws.Cells(1, C).Value)
        Rl = LastRow(C, Ws)
        For R = 1 To Rl
            S = Ws.Cells(R, C).Value
            If S = "" Then GoTo end_of_for '<---------------------------- HERE!
            If InStr(1, LookIn, Ws.Cells(R, C).Value, vbTextCompare) Then
                ExpenseColumn = C
                Exit Function
            End If
end_of_for:
        Next R
        C = C + 1
    Loop
End Function

Open in new window


It seems to be the
  R = .Cells(.Rows.Count, Col).End(xlUp).Row

Open in new window

that returns 12 regardless of column.

I wonder if the state of the cells are changed when you enter something in them and then delete it afterwards. I marked the entire region with list data and copied back in a version with only uppercase words until I realised that the InStr function checks and matches regardless of case and then I copied back the original values, so strictly speaking I have copied in empty values in the cells row 6-12 in column 2. Perhaps this is why? Did you understand any of that? ;-)

Erroneous error?

Thx!

IVer
0
FaustulusCommented:
Hi IVer,
I have interated the additional check. It is only necessary if you have rows without contents. Since I don't think that you have such rows it is more likely that the fault you found is related to the other problem. I.e., you only hit blank cells in a column if LastRow isn't set correctly. Anyway, here is the revised code.
Private Function ExpenseColumn(LookIn As String) As Long
    
    Dim Ws As Worksheet
    Dim Rl As Long
    Dim R As Long, C As Long
    
    Dim S As String
    
    Set Ws = ThisWorkbook.Worksheets(ListSheet)
    C = 1
    Do While Len(Ws.Cells(1, C).Value)
        Rl = LastRow(C, Ws)
        For R = 1 To Rl
            S = Ws.Cells(R, C).Value
            If InStr(1, LookIn, Ws.Cells(R, C).Value, vbTextCompare) And _
               Len(S) > 0 Then
                ExpenseColumn = C
                Exit Function
            End If
        Next R
        C = C + 1
    Loop
End Function

Open in new window

"Best practise" has it that GoTo is a disruptive command, to be avoided. If .. Then .. Else .. End If allows for free flow of the code's logic and is preferred for that reason.

Now, the Function LastRow() is just a function. If you alter the function it will not work as advertised. Therefore, please don't alter it.
The function call is here:-  Rl = LastRow(C, Ws)
C is the parameter which turns into Col in the function.
Of course, we are refering to the list of items being checked for their occurrence in your posting items. So, if your columns there don't have the same length, it is correct that C refers to the column being examined. C is different in each round of the loop - unless you override the parameter by changing something in the function itself.
I didn't quite catch your explanation, but if you inserted blanks in the lists this would cause a problem. Also, if you have cells at the end of the list containing blank spaces LastRow will include them. In principle, the Lists are Admin controlled and should be perfect. Anyway, you are right in looking for the fault there.
If you continue to have a problem with this plese let me take a look at your Lists sheet.
0
Iver Erling ArvaSenior consultantAuthor Commented:
Hi, Faustulus!

I didn't change the LastRow() function, but just debugged it and saw what the different commands returned. That is how I discovered that it returned the same number of rows for column 2 as it did for column 1 regardless of the fact that column 1 had 12 values and column 2 had 5.

I have not deliberately entered empty values, but have copied out and in a bloc of 12x6 rows/columns which consisted of 12 values in col1 and 5 values in col2 plus some values in the other columns. If this action changes the state of the empty cells 6-12 in col2 and the empty cells in cols3-6, that may have caused the strange behavior I saw in LastRow().

Other than that I have now altered / expanded the code to work with my bank statements, and it works really great.

Thanks!
IVer in Oslo
0
FaustulusCommented:
Hi IVer,
Seems that all's well now. I'm glad you got it to work for you.
Regards,
Faustulus
0
[ fanpages ]IT Services ConsultantCommented:
[ http://www.ee-stuff.com/Newsletter-old/102313newsletter.htm ]

IverErling was trying to come up with a spreadsheet that would look for a substring in a range of strings. Both fanpages and Faustulus came up with solutions and sample workbooks that accomplished the same task in different ways, and even gave IverErling an introduction to VBA programming: First, thank you very much for GREAT help! Both your solutions work great and illustrate in a good way that this can be done. Second, this was just a sample to illustrate my "problem". Therefore, Faustulus is correct in assuming that AA and AB meant "somewhere else". I never thought of making a program for it. I have actually programmed quite a lot in VB before, so looking into VBA is definitely an option, and I will study your code and use it as my introduction to VBA. Again, thanks a lot for thorough and quick replies!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.