Как найти значение на другом листе и вернуть меньше X?

Question

Я должен написать код, который найдет город и вернет расстояние, меньшее, чем я выбрал. Например, в листе А1 ячейка A2 - это название города, в ячейке А3 - расстояние. В листе 2 приведен список городов и их расстояние .:

Я хочу, чтобы в строке 1 был найден город (из ячейки А1 листа 1) и возвращались только города, страны и расстояние какие значения расстояния меньше, чем значение в ячейке листа А3.

Я пробовал этот код, но я не уверен, что мне делать дальше:

Dim Rng_Header As Range: Set Rng_Header = Sheets("Sheet2").[d1:h1]
Dim Ws1 As Worksheet: Set Ws1 = Sheets("Sheet1")
Dim index_column As Variant
   index_column = Application.Match(Ws1.[a2], Rng_Header, 0)    'find index column in Rng_Header

Спасибо за вашу помощь

Answer 1

Пожалуйста, изучите код ниже. Вам будет весело. Кроме того, он также делает то, что вы хотите.

Sub ListNearerCities()

    Const Target As String = "D2"           ' place the output there (on Sheet1)

    Dim Fun As Variant                      ' output array
    Dim n As Integer                        ' Fun index counter
    Dim Ws As Worksheet
    Dim City As String                      ' Value of A2
    Dim Distance As Long                    ' value of A3
    Dim WsData As Worksheet
    Dim Data As Variant
    Dim Rng As Range
    Dim R As Long, C As Long                ' Row / Column

    Set Ws = Worksheets("Sheet1")
    With Ws
        City = .Cells(2, "A").Value
        Distance = .Cells(3, "A").Value
        With .Range(Target).Resize(1, 3)
            ' clear & reset the output area
            .EntireColumn.ClearContents
            With .Offset(-1)
                .Value = Split("City Country Distance")
                .Font.Bold = True
            End With
        End With
    End With

    Set WsData = Worksheets("Sheet2")
    With WsData
        On Error Resume Next
        Set Rng = .Range(.Cells(1, 4), .Cells(1, .Columns.Count).End(xlToLeft))
        C = Application.Match(City, Rng, 0)     'find index column among column captions
        If Err Then
            MsgBox """" & City & """ isn't listed.", _
                   vbInformation, "No data available"
            Exit Sub
        End If

        C = C + 3       ' convert Rng column to Sheet column
        Set Rng = .Range(.Cells(1, "A"), .Cells(.Rows.Count, C).End(xlUp))
        Data = Rng.Value

        ReDim Fun(1 To 3, 1 To UBound(Data))
        For R = 2 To UBound(Data)
            If Distance > Val(Data(R, C)) Then
                If (Val(Data(R, C)) > 0) And (City <> Data(R, 3)) Then
                    n = n + 1
                    Fun(1, n) = Data(R, 1)
                    Fun(2, n) = Data(R, 3)
                    Fun(3, n) = Data(R, C)
                End If
            End If
        Next R
    End With

    If n Then
        ReDim Preserve Fun(1 To 3, 1 To n)
        Ws.Range(Target).Resize(UBound(Fun, 2), UBound(Fun)).Value = Application.Transpose(Fun)
        ' re-use of obsolete string variable
        City = n & " record" & IIf(n = 1, " was", "s were")
    Else
        City = "No data matching the criteria was"
    End If

    MsgBox City & " found.", vbInformation, "Search report"
End Sub

Answer 2

Массивный подход с использованием FilterXML (VBA 2013 +)

Эта задача не так тривиальна, как может показаться.

Список расстояний объединяет два города со значением расстояния в каждом перекрестке; положительные значения показаны здесь только в левом нижнем разделе, чтобы избежать повторяющихся записей. Таким образом, вместо n * n = n² записей ввод состоит только из n * (n - 1)/2 положительных расстояний, так как n нулевые значения серого не отображаются в OP, а правая верхняя половина не имеет (избыточного) ввода.

Я завершен список значений серого расстояния для демонстрации внутренней структуры с вертикальным фокусом на Лос-Анджелес , где оранжевые значения должны быть заполнены левыми горизонтальными значениями Лос-Анджелеса, связанными с Парижем и Лондоном ( Кстати, забудьте о реальных расстояниях) :

Этот подход объединяет быстрые методы массива с возможностями WorksheetFunction FilterXML(), доступной в версиях 2013 +.

Sub ExampleCall()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[A]define city & maximum distance
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    With Sheet1
        Dim city     As String: city = .Range("A2").Value
        Dim distance As Long:   distance = .Range("A3").Value
    End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[B]get results via function getNearest()
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Dim results
    results = getNearest(city, distance)    ' getNearest returns 2-dim results array
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[C]write results to target
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    With Sheet1.Range("D2")
        .Resize(1000, 3) = vbNullString
        .Resize(1, 3).Offset(-1) = Array("City", "Country", "Distance")
        .Resize(UBound(results), 3).Value = results
    End With
End Sub

Пример результата Лос-Анджелес, <156 км </strong>

Обратите внимание, что Программно добавленное парижское расстояние в вертикальном столбце данных для Лос-Анджелеса действительно из-за заданного условия, второе пустое расстояние ровно 156 до Лондона меньше 156 км и, таким образом, опущено.

* 1 038 * Справочные функции

• getNearest() для структурирования основных этапов обработки
• getData() для получения всех необходимых данных (при условии хорошо сформированного xml строка) и
• xCities(), демонстрирующие использование FilterXML()

Function getNearest(city, distance) As Variant()

Const COLOFFSET = 3
With Sheet2
'[0]get last row in column A:A
    Dim n: n = .Range("A" & .Rows.Count).End(xlUp).Row
'[1]get base references (moving due to current city number)
    Dim horizontal As Range: Set horizontal = .Range("1:1").Resize(1, n - 1).Offset(columnoffset:=COLOFFSET)
    Dim vertical   As Range: Set vertical = .Range("C2:C" & n)
End With

'[2]get cities
    Dim cities: cities = Application.Transpose(vertical.Offset(0, -2).Value)
    ReDim Preserve cities(0 To UBound(cities) - 1)

'[3]get current city number (ordinal, i.e. 1-based)
    Dim curr: curr = Application.Match(city, cities, 0)
    If IsError(curr) Then curr = 10000    ' provide for not found

'[4]get data prepared for XML filtering and pass them to xCities using FilterXML function
    Dim data: data = getData(cities, curr, horizontal, vertical)

'[5]return function results
    getNearest = xCities(data, distance)     ' << return results

End Function

Function getData(cities, ByVal curr As Long, horizontal As Range, vertical As Range) As Variant()
With horizontal.Parent
'[1]get current data
    Dim ctry: ctry = Application.Transpose(vertical)
    Dim v:    v = Application.Transpose(vertical.Offset(columnoffset:=curr).Value)
    Dim h:    h = Application.Transpose(Application.Transpose(horizontal.Offset(rowoffset:=curr).Value))
    Debug.Print Join(h, "|")
'[2]reorg v to get
    Dim i As Long
    For i = 1 To UBound(v)
        ' complete zero data at column top
        If Val(v(i)) <= 0 Then v(i) = h(i)
        ' add some node formatting
        v(i) = "<c ctry='" & ctry(i) & _
               "' km='" & v(i) & "'>" & _
               cities(i - 1) & "</c>"
    Next i
End With
getData = v
End Function

Function xCities(v, ByVal distance As Long)
'Purpose: return 2-dim array with integrated FilterXML results

'create wellformed XML string out of passed array data
Dim myXML As String: myXML = "<cities>" & Join(v) & "</cities>"
Debug.Print myXML
Dim myXPath As String: myXPath = "//c[@km>0][@km<" & distance & "]"

On Error Resume Next
Dim results
results = WorksheetFunction.FilterXML(myXML, myXPath)

If Err.Number Then
    MsgBox "nothing found"
    xCities = Array(Array(Empty), Array(Empty))
Else
    Dim results2
    results2 = WorksheetFunction.FilterXML(myXML, myXPath & "/@ctry")
    Dim results3
    results3 = WorksheetFunction.FilterXML(myXML, myXPath & "/@km")
    'provide for single findings - only 1 city (<< Edit as of 2020-04-03)
    If TypeName(results) = "String" Then
         ReDim tmp(1 To 1, 1 To 3)
         tmp(1, 1) = results: tmp(1, 2) = results2: tmp(1, 3) = results3
         xCities = tmp
    Else                    ' several cities found
        ReDim Preserve results(1 To UBound(results), 1 To 3)
        Dim i As Long
        For i = 1 To UBound(results)
            results(i, 2) = results2(i, 1)
            results(i, 3) = results3(i, 1)
        Next i
        xCities = Application.Index(results, Evaluate("row(1:" & UBound(results) & ")"), Array(1, 2, 3))
    End If

End If
End Function

Дополнительная подсказка

Правильно сформированная строка XML для Лос-Анджелес будет выглядеть следующим образом: Функция FilterXML() нуждается в выражении XPath, чтобы получить действительные узлы. Обратите внимание на префикс @ при ссылке на такие атрибуты, как km или ctry в узлах <c>. Скобки [] указывают на соответствующее условие, двойное значение sh // обозначает поиск на любом уровне иерархии, поэтому вам не нужно ссылаться на DocumentElement из <cities>...</cities>

<cities>
    <c ctry='France' km='38'>Paris</c>
    <c ctry='UK' km='156'>London</c>
    <c ctry='USA' km='0'>Los Angeles</c> 
    <c ctry='Italy' km='218'>Roma</c> 
    <c ctry='Italy' km='88'>Milan</c> 
    <c ctry='France' km='112'>Nica</c> 
    <c ctry='Ireland' km='68'>Dublin</c>
</cities>