Создать диапазон на основе критериев в двух столбцах

Question

Это касается другого вопроса, который я недавно опубликовал, и @Stavros Jon любезно помог мне.

Я пытаюсь создать именованный диапазон на основе критериев в столбце B и столбце C. Я хочу создать диапазон, если столбец B содержит слово «OSI», а столбец C содержит слово «Language».

Я попытался отредактировать свой предыдущий код, но я не могу понять правильный синтаксис и получить объектную ошибку со строкой счетчика.

Sub another()

'Create Ranges:

Dim featuresRng As Range
Dim rng As Range
Dim sht As Worksheet
Dim counter As Long
Dim cell As Range
Set sht = ThisWorkbook.Worksheets("Features")
Set featuresRng = sht.Range(sht.Range("C1"), sht.Range("C" & sht.Rows.Count).End(xlUp)) 'dynamically set the range of features
Set featuresRng2 = sht.Range(sht.Range("B1"), sht.Range("B" & sht.Rows.Count).End(xlUp))

counter = 0 'this counter will help us avoid Union(Nothing, some range), which would give an error

For Each cell In featuresRng 'loop through the range of features
    If featuresRng.cell.Value = "Language" And featuresRng2.cell.Value = "OSI" Then
        counter = counter + 1
        If counter = 1 Then
            Set rng = sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))
        Else
            Set rng = Union(rng, sht.Range(cell.Offset(0, 1), cell.Offset(0, 3))) 'build the range
        End If
    End If
Next cell
Debug.Print rng.Address
ThisWorkbook.Names.Add "OSILAng", rng

End Sub

Как мне отредактировать мой код, чтобы включить эти два критерия?

Кроме того, иногда мой текст в столбце B будет содержать слова в других ячейках, таких как «Фильтр» и «Фильтр и поиск», я также хочу сделать свой диапазон из текста EXACT в ячейках столбца C, а не просто «содержит» этот текст.

Заранее спасибо!

Answer 1

Попробуйте это

Sub another()

Dim featuresRng As Range, NewArr As Variant
Dim rng As Range
Dim sht As Worksheet
Dim sRng As String
Dim i As Long

Set sht = ThisWorkbook.Worksheets("Features")
Set featuresRng = sht.Range(sht.Range("B1"), sht.Range("C" & sht.Rows.Count).End(xlUp))
rngArray = featuresRng
ReDim NewArr(1 To 1)
y = 1
For i = 1 To UBound(rngArray)
    If rngArray(i, 2) = "Language" And rngArray(i, 1) = "OSI" Then
        ReDim Preserve NewArr(1 To y)
        NewArr(y) = featuresRng.Rows(i).Offset(0, 3).Address
        y = y + 1

    End If
Next i

sRng = Join(NewArr, Application.DecimalSeparator)
ThisWorkbook.Names.Add "OSILAng", sht.Range(sRng)

End Sub