Question

我有使用.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

Answer 1

问题在于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版本还有另一个问题。您将单元格地址作为键放入字典中，但是您正在对字典测试值以查看它是否已存在。从yuor代码看，您似乎想要一个唯一值的字典。而不是破坏使用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

VBA - 不要在范围内抓住标题

1 个答案: