[英]VBA - do not grab header in range
我有使用 .Find 方法查找标题“CUTTING TOOL”的代码。 它在打开的文件中循环访问多个文件和多个工作表。
我遇到了一个问题,当它在一个打开的文件中处理多个工作表并且标题下的列是空的时,它会打印出标题“CUTTING TOOL”。 它不会在初始工作表或不包含多个工作表的工作簿中执行此操作。 任何想法如何解决它?
'(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
问题在于GetValue
函数。 当标题下方没有值时,范围选择最终会选择空单元格及其上方的标题。
您也没有正确实现上一篇文章中的If Len(v) = 0 Then
。 您已将其添加到永远不会使用v
值的代码区域中。
正如另一个答案中提到的,您应该真正为Dictionary
使用早期绑定,以便该函数可以返回Dictionary
而不是Object
。 在使用GetValue
函数的代码中,您使用的是:
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.Count > 0 Then
' do something...
ElseIf dict = "" Then
' do something else...
End If
这是一个问题,因为您的代码无法确定它是否有字典或空字符串。 但是如果你总是返回一个字典,即使是空的,那么你可以使用:
Set dict = GetValues(hc.Offset(1, 0), "SplitMe")
If dict.Count > 0 Then
' do something...
Else Then
' do something else...
End If
哪个更一致。 如果代码使用GetValue
,它总是得到一个Dictionary
但它可能不包含任何值。
您的GetValues
版本还有另一个问题。 您将单元格地址作为键放入字典中,但您正在根据字典测试单元格的值以查看它是否已经存在。 从您的代码来看,您似乎想要一个包含唯一值的字典。 而不是破坏您使用d.Items
其他代码,我将更改GetValue
函数,以便它将单元格值存储在字典中的键和值中。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.