VBA - не захватить заголовок в диапазоне

Question

У меня есть код, который ищет заголовок «РЕЗКА ИНСТРУМЕНТА» с использованием метода .Find. Он пропускает несколько файлов и несколько рабочих листов в открываемых файлах.

Я столкнулся с проблемой :, что, когда он проходит через несколько листов в одном открытом файле, а столбец пуст под заголовком, он печатает заголовок «РЕЗКА ИНСТРУМЕНТА». Это не делается на начальном листе или в книгах, которые не содержат нескольких рабочих листов. Есть идеи, как это исправить?

'(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