VBA - Copy value if cell CONTAINS certain value rather than equal to or not equal to

Question

I have a working macro that loops through folder to open files and get important info from the columns of names "HOLDER" and "CUTTING TOOL" and printing all the info to one excel document, masterfile.

I have run into the problem that in the “HOLDER” column, sometimes there is extra information like “Holder / Toolbox” but it is not consistent. I have it working with “HOLDER” but I was wondering if it was possible to still do that regardless of if there is that extra text in the HOLDER header name or if it is lowercase rather than all capitals. Thank you for any help you can provide!

This is the code that deals with the "HOLDER" section . Below that is the full code for better reference (section 4 regards the section I am tinkering with and section 8 is the function it references).

'find the headers on the sheet
Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")

...

'(4)
            'find HOLDER on the source sheet
            Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
            If Not hc3 Is Nothing Then

                Set dict = GetValues(hc3.Offset(1, 0))
                If dict.count > 0 Then
                    Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                    'add the values to the master list, column 2
                    d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                End If
            Else
                'header not found on source worksheet
            End If

...

'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
    Dim dict As Object
    Dim rng As Range, c As Range
    Dim v
    Dim spl As Variant

    Set dict = CreateObject("scripting.dictionary")

    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 And Not dict.exists(v) Then

            If Not IsMissing(vSplit) Then
            spl = Split(v, ";")

            v = spl(0)
            End If

            If Not IsMissing(vSplit) Then
            spl = Split(v, ",")

            v = spl(0)
            End If
            dict.Add c.Address, v
        End If
    Next c
    Set GetValues = dict
End Function

FULL CODE

Option Explicit

Sub LoopThroughDirectory()

    Const ROW_HEADER As Long = 10

    Dim objFSO As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim MyFolder As String
    Dim StartSht As Worksheet, ws As Worksheet
    Dim WB As Workbook
    Dim i As Integer
    Dim LastRow As Integer, erow As Integer
    Dim Height As Integer
    Dim RowLast As Long
    Dim f As String
    Dim dict As Object
    Dim hc As Range, hc1 As Range, hc2 As Range, hc3 As Range, d As Range

    Set StartSht = Workbooks("masterfile.xlsm").Sheets("Sheet1")

    'turn screen updating off - makes program faster
    Application.ScreenUpdating = False

    'location of the folder in which the desired TDS files are
    MyFolder = "C:\Users\trembos\Documents\TDS\progress\"

    'find the headers on the sheet
    Set hc1 = HeaderCell(StartSht.Range("B1"), "HOLDER")
    Set hc2 = HeaderCell(StartSht.Range("C1"), "CUTTING TOOL")

    'create an instance of the FileSystemObject
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'get the folder object
    Set objFolder = objFSO.GetFolder(MyFolder)
    i = 2


    'loop through directory file and print names
'(1)
    For Each objFile In objFolder.Files
        If LCase(Right(objFile.Name, 3)) = "xls" Or LCase(Left(Right(objFile.Name, 4), 3)) = "xls" Then
'(2)
            'Open folder and file name, do not update links
            Set WB = Workbooks.Open(fileName:=MyFolder & objFile.Name, UpdateLinks:=0)
            Set ws = WB.ActiveSheet
'(3)
                'find CUTTING TOOL on the source sheet
                Set hc = HeaderCell(ws.Cells(ROW_HEADER, 1), "CUTTING TOOL")
                If Not hc Is Nothing Then

                    Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
                        'add the values to the master list, column 3
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    End If
                Else
                    'header not found on source worksheet
                End If
'(4)
                'find HOLDER on the source sheet
                Set hc3 = HeaderCell(ws.Cells(ROW_HEADER, 1), "HOLDER")
                If Not hc3 Is Nothing Then

                    Set dict = GetValues(hc3.Offset(1, 0))
                    If dict.count > 0 Then
                        Set d = StartSht.Cells(Rows.count, hc1.Column).End(xlUp).Offset(1, 0)
                        'add the values to the master list, column 2
                        d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
                    End If
                Else
                    'header not found on source worksheet
                End If
'(5)
            'print filename and TDS information
            With WB
                For Each ws In .Worksheets
                        'print the file name to Column 1
                        StartSht.Cells(i, 1) = objFile.Name
                        StartSht.Cells((GetLastRowInColumn(StartSht, "C")), 1) = objFile.Name

                        'print TDS name from J1 cell to Column 4
                        With ws
                            .Range("J1").Copy StartSht.Cells(i, 4)
                        End With
                        i = GetLastRowInSheet(StartSht) + 1
                'move to next file
                Next ws
'(6)
                'close, do not save any changes to the opened files
                .Close SaveChanges:=False
            End With
        End If
    'move to next file
    Next objFile
    'turn screen updating back on
    Application.ScreenUpdating = True
    ActiveWindow.ScrollRow = 1
'(7)
End Sub

'(8)
'get all unique column values starting at cell c
Function GetValues(ch As Range, Optional vSplit As Variant) As Object
    Dim dict As Object
    Dim rng As Range, c As Range
    Dim v
    Dim spl As Variant

    Set dict = CreateObject("scripting.dictionary")

    For Each c In ch.Parent.Range(ch, ch.Parent.Cells(Rows.count, ch.Column).End(xlUp)).Cells
        v = Trim(c.Value)
        If Len(v) > 0 And Not dict.exists(v) Then

            If Not IsMissing(vSplit) Then
            spl = Split(v, ";")

            v = spl(0)
            End If

            If Not IsMissing(vSplit) Then
            spl = Split(v, ",")

            v = spl(0)
            End If
            dict.Add c.Address, v
        End If
    Next c
    Set GetValues = dict
End Function

'(9)
'find a header on a row: returns Nothing if not found
Function HeaderCell(rng As Range, sHeader As String) As Range
    Dim rv As Range, c As Range
    For Each c In rng.Parent.Range(rng, rng.Parent.Cells(rng.Row, Columns.count).End(xlToLeft)).Cells
        If Trim(c.Value) = sHeader Then
            Set rv = c
            Exit For
        End If
    Next c
    Set HeaderCell = rv
End Function

'(10)
Function GetLastRowInColumn(theWorksheet As Worksheet, col As String)
    With theWorksheet
        GetLastRowInColumn = .Range(col & .Rows.count).End(xlUp).Row
    End With
End Function


'(11)
Function GetLastRowInSheet(theWorksheet As Worksheet)
Dim ret
    With theWorksheet
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            ret = .Cells.Find(What:="*", _
                          After:=.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
        Else
            ret = 1
        End If
    End With
    GetLastRowInSheet = ret
End Function

Answer 1

Well, InStr helps finding out whether or not a substring is contained in a string. Basically, what it returns is what is the position of substring in the string; so, a line like:

Instr ("hello world!", "h")

will return 1 First parameter is the string where you want to look, and the second is the substring you want to look for.

So, if the return is different from zero, you know the substring is contained. You would check like this:

If InStr(string, substring) <> 0 then
'do code
End If

Also, for the case-sensitive scenario:

You may want to put the cell value into a string variable, but converted to Upper Case; then check against "HOLDER" and whatnot. This won't change the value in the cell, it's just for comparison sake. Just do:

dim uString as String

uString = UCase(c.Value)

Answer 2

The part that needs adjusting is the part that searches your header row, comparing the values. It looks like this is in the HeaderCell function. The specific line that looks to do the comparison is:

If Trim(c.Value) = sHeader Then

This is comparing the contents of each cell in the header row to the passed in value (in your case sHeader = "Holder").

You would be better off doing a test to see if sHeader is in the cell value, not equal to the cell value. The InStr function is perfect for this. Something along the lines of (untested air code):

If InStr(c.Value, sHeader) <> 0 Then

This will search the contents of each cell in your header row, looking to see if the value passed in to sHeader is anywhere in the value.