如何在另一张表中找到值并返回小于 X 的值？

Question

我必须编写一个代码来查找城市并返回小于我选择的距离。 例如，在 sheet1 中，单元格 A2 是城市名称，在单元格 A3 中是距离。 在 sheet2 中是城市列表及其距离。：

我希望在第 1 行中找到城市（来自 Sheet1 单元格 A2）并仅返回距离值小于 sheet1 单元格 A3 中的值的城市、国家和距离。

我已经尝试过这段代码，但我不确定接下来应该做什么：

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 到伦敦低于 156 公里，因此被省略。

帮助功能

• 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

进一步提示

Los Angeles 格式良好的 XML 字符串如下所示： FilterXML() 函数需要 XPath 表达式来获取有效节点。 在 <c> 节点中引用 km 或 ctry 等属性时，请注意 @ 前缀。 [] 括号表示相关条件，双斜杠// 表示搜索任意层级，因此您无需参考<cities>...</cities> 的DocumentElement

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