VBA - do not grab header in range - vba

Question

I have code that looks for the header "CUTTING TOOL" using a .Find method. It loops through multiple files and multiple worksheets in the opening files.
I have run into the problem that when it goes through multiple worksheets in one open file and the column is empty under the header, it will print out the header, "CUTTING TOOL". It does not do this in the initial worksheet or in workbooks that do not contain multiple worksheets. Any ideas how to fix it?
'(3)
'find CUTTING TOOL on the source sheet'
If Not ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then
Set hc = ws.Range("A1:M15").Find(What:="CUTTING TOOL", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
ElseIf dict = "" Then
StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0) = "NO CUTTING TOOLS PRESENT"
End If
ElseIf Not ws.Range("A1:M15").Find(What:="TOOL CUTTER", LookAt:=xlWhole, LookIn:=xlValues) Is Nothing Then ' find TOOL CUTTER on sheet
Set hc = ws.Range("A1:M15").Find(What:="TOOL CUTTER", LookAt:=xlWhole, LookIn:=xlValues)
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.count > 0 Then
'add the values to the master list, column 3
Set d = StartSht.Cells(Rows.count, hc2.Column).End(xlUp).Offset(1, 0)
d.Resize(dict.count, 1).Value = Application.Transpose(dict.items)
Else
End If
Else
If hc3 Is Nothing Then
StartSht.Range(StartSht.Cells(i, 3), StartSht.Cells(GetLastRowInColumn(StartSht, "C"), 1)) = "NO CUTTING TOOLS PRESENT!"
End If
End If
...
...
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 Not dict.exists(v) Then
If Len(v) > 0 Then
'exclude any info after ";"
If Not IsMissing(vSplit) Then
spl = Split(v, ";")
v = spl(0)
End If
'exclude any info after ","
If Not IsMissing(vSplit) Then
spl = Split(v, ",")
v = spl(0)
End If
End If
dict.Add c.Address, v
End If
If Len(v) = 0 Then
v = "none"
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
'copy cell value if it contains some string "holder" or "cutting tool"
If Trim(c.Value) = sHeader Then
Set rv = c
Exit For
End If
Next c
Set HeaderCell = rv
End Function

Answer 1

The problem lies in the GetValue function. When there is no value below the header, the range selection ends up selecting the empty cell plus the heading above it.
You have also not properly implemented the If Len(v) = 0 Then from a previous post. You have added it in a region of the code where the value of v will never get used.
As mentioned in another answer, you should really use early binding for the Dictionary so that the function can return a Dictionary rather than an Object. In the code that uses the GetValue function you are using this:
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.Count > 0 Then
' do something...
ElseIf dict = "" Then
' do something else...
End If
This is a problem because your code cannot be sure if it has a dictionary or an empty string. But if you always return a dictionary, even if empty, then you can use:
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.Count > 0 Then
' do something...
Else Then
' do something else...
End If
Which is more consistent. If the code uses GetValue, it always gets a Dictionary but it might not contain any values.
There is another problem with your version of GetValues. You are putting the cell address into the dictionary as the key but you are testing the value of the cell against the dictionary to see if it already exists. From yuor code, it looks like you want a dictionary of the unique values. Rather than break your other code that uses d.Items I will change the GetValue function so it stores the cell value in both key and value in the dictionary.
Function GetValues(ch As Range, Optional vSplit As Variant) As Scripting.Dictionary
Dim dict As Scripting.Dictionary
Dim dataRange As Range
Dim cell As Range
Dim theValue As String
Dim splitValues As Variant
Set dict = New Scripting.Dictionary
Set dataRange = ch.Parent.Range(ch, ch.Parent.Cells(Rows.Count, ch.Column).End(xlUp)).Cells
' If there are no values in this column then return an empty dictionary
' If there are no values in this column, the dataRange will start at the row
' *above* ch and end at ch
If (dataRange.Row = (ch.Row - 1)) And (dataRange.Rows.Count = 2) And (Trim(ch.Value) = "") Then
GoTo Exit_Function
End If
For Each cell In dataRange.Cells
theValue = Trim(cell.Value)
If Len(theValue) = 0 Then
theValue = "none"
End If
If Not dict.exists(theValue) Then
'exclude any info after ";"
If Not IsMissing(vSplit) Then
splitValues = Split(theValue, ";")
theValue = splitValues(0)
End If
'exclude any info after ","
If Not IsMissing(vSplit) Then
splitValues = Split(theValue, ",")
theValue = splitValues(0)
End If
dict.Add theValue, theValue
End If
Next cell
Exit_Function:
Set GetValues = dict
End Function