VBA 循环遍历范围以创建满足条件的新数据输出

Question

我有一组数据（样本）：

Maturity    Price
17/11/2017  2165
15/12/2017  2165
17/11/2017  2170
15/12/2017  2170
19/01/2018  2170

对于列表中的每个价格，我想创建此价格与列表中所有其他价格的输出（仅在日期相同的情况下）

Function Spreads()
    Dim data_range As Range
    Dim data As Variant, output_range As Variant
    Dim i As Integer, j As Integer, x As Integer

    Set data_range = Worksheets("Strategies").Range("A1", "B10")
    data = data_range.Value2

    For i = LBound(data) + 1 To UBound(data)
        For j = LBound(data) + 1 To UBound(data)
            If data(i, 1) = data(j, 1) Then
                If data(i, 2) < data(j, 2) Then
                    ReDim Preserve output_range(x, 3)
                    output_range(x, 1) = data(i, 1)
                    output_range(x, 2) = data(i, 2)
                    output_range(x, 3) = data(j, 2)
                    x = x + 1
                End If
            End If
        Next
    Next

    PrintArray output_range, ActiveWorkbook.Worksheets("Strategies").[d1]

End Function

Sub PrintArray(data As Variant, Cl As Range)
    Cl.Resize(UBound(data, 1), UBound(data, 2)) = data
End Sub

所以我上表的输出是：

17/11/2017 2165 2170 
15/12/2017 2165 2170

但是，当我运行它时，什么也没有发生。任何建议将不胜感激？

Answer 1

您可以使用Dictionary 对象来实现您所需要的。

参见下面的代码，代码的 cmets 中有解释。

Option Explicit

Sub UseDict()

Dim LastRow     As Long
Dim Dict        As Object
Dim Key         As Variant
Dim Price       As Variant
Dim i           As Long

With Sheets("Strategies")
    ' find last row with data in column "A" (Adress)
    LastRow = .Cells(.rows.Count, "A").End(xlUp).Row

    Set Dict = CreateObject("Scripting.Dictionary")

    For i = 2 To LastRow
        If Not Dict.exists(.Range("A" & i).Value) Then ' check if current date already exists in the Dictionary
            Dict.Add .Range("A" & i).Value, .Range("B" & i).Value ' add date as Key
        Else
            ' date already exists in Dictionary, append the Price as the Key Value
            ' add "," so it will be easy to split later to an array
            Dict(.Range("A" & i).Value) = Val(Dict(.Range("A" & i).Value)) & "," & .Range("B" & i).Value
        End If
    Next i

    ' loop through the dictionary, and print values per key (per date)
    ' put in columns C and D , just for comparison reasons
    i = 2 ' start from 2nd row

    For Each Key In Dict.Keys
        Price = Split(Dict(Key), ",") ' split the merged mulitple prices back to array

        ' splitting values from "Merged" string Key to array
        .Range("C" & i).Value = Key
        .Range("D" & i).Resize(1, UBound(Price) + 1).Value = Price
        i = i + 1
    Next Key

End With

End Sub

Answer 2

这是问题的可能解决方案。想象一下，您的输入如下所示：

因此，如果您开始在 VBA 中使用字典结构，您将能够实现以下目标：

字典结构的问题在于它通常需要一个键和一个值。除非你找到解决办法。例如，您可以定义一个复杂的分隔符，或者您可以将数组作为值传递。在这种情况下，我定义了一个复杂的分隔符：

Public Const DELIM As String = "ITISHELLOWEENTODAY"

Public Sub TestMe()

    Dim myDict      As Object
    Dim cnt         As Long
    Dim cnt2        As Long        
    Dim myKey       As String
    Dim myVal       As String
    Dim objK        As Variant
    Dim lngTotal    As Long

    Set myDict = CreateObject("Scripting.Dictionary")        
    For cnt = 1 To 6
        myKey = Cells(cnt, 1)
        myVal = Cells(cnt, 2)            
        If myDict.Exists(myKey) Then
            myDict(myKey) = Join(Array(myDict(myKey), myVal), DELIM)
        Else
            myDict.Add myKey, myVal
        End If
    Next cnt

    For Each objK In myDict.Keys
        cnt = cnt + 1
        Cells(cnt, 1) = objK            
        Dim myArr As Variant
        myArr = Split(myDict(objK), DELIM)

        For cnt2 = LBound(myArr) To UBound(myArr)
            Cells(cnt, 2 + cnt2) = myArr(cnt2)
        Next cnt2
    Next objK

End Sub

它所做的几乎就是在找到第二个值时将像 1ITISHELLOWEENTODAY11 这样的键的值结合起来，当它必须将它们打印回 excel 时，它会创建一个数组，由分隔值分割（与Split(myDict(objK), DELIM))。并打印到下一列。