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对象实现所需。

请参阅下面的代码，解释代码的注释。

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)）。并打印到下一栏。

VBA循环通过范围创建符合标准的新数据输出

2 个答案: