在与今天相同的日期提取每年的值

Question

我想在VBA上编写代码，但是不知道如何： 我有日期一栏（从1998年至今的每天）和价格一栏的数据。

我想做的是每年与今天同一天在不同的excel表上显示价格。

例如：如果今天是2018年8月28日，我想知道28/08 / 2017、28 / 08/2016，...，28/08/1998的价格。

非常感谢！

Answer 1

您可以将值读入数组并循环该数组。比较第1列（日期）的左5个字符是否与今天日期的左5个字符匹配（用Date函数返回）。将符合条件的值存储到字典中。将字典写到末尾的一张纸上。您还可以简单地使用： If Format$(arr(i, 1), "dd/mm") = Format$(Date, "dd/mm")然后输入日期。

Option Explicit
Public Sub test()
    Dim arr(), i As Long, results As Object
    Set results = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Worksheets("Sheet1")
        arr = .Range("A2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value '< read columns A and B into an array (Dates and Prices)
        For i = LBound(arr, 1) To UBound(arr, 1) '< Loop the dates in the array (column 1)
            If Left$(arr(i, 1), 5) = Left$(Date, 5) Then 'compare whether left 5 characters match i.e. same dd/mm irrespective of year
              results(arr(i, 1)) = arr(i, 2)  'if match add the arr(i,1) date as key to dictionary; add the arr(i,2) price as the value associated with the key
            End If
        Next
    End With
    With ThisWorkbook.Worksheets("Sheet2")
        .Range("A1").Resize(results.Count, 1) = Application.WorksheetFunction.Transpose(results.keys)
        .Range("B1").Resize(results.Count, 1) = Application.WorksheetFunction.Transpose(results.items)
    End With
End Sub

---

如果在表中完成了比较，则这里是一个比较示例，显示了一个限定行。对存储在数组中的每一行进行此比较。

字典results最终以符合条件的行列A（date）作为键，而列B（Price）作为值。

您可以访问最终字典的所有.Items或.Keys，在每种情况下都会生成一个数组，可以将其转置以写入工作表中的列。

您的字典最终将存储合格行的键值对，其示例如下：

取决于工作表中的格式，您可能需要：

If Format$(arr(i, 1), "dd/mm") = Format$(Date, "dd/mm") Then

---

试运行：

Answer 2

不理想，但尝试过并且可以工作，只要将日期和目标日期设置为文本即可。

Public Sub Test()

Dim i As Integer

    i = 0

    For Each c In ThisWorkbook.Sheets("Sheet1").Range("A1:A5")

        If Left(c.Value, 6) = ThisWorkbook.Sheets("Sheet1").Range("D1:D1").Value Then

            i = i + 1 

            ThisWorkbook.Sheets("Sheet1").Range("F" & i & ":F" & i).Value = c.Offset(0, 1).Value

        End If

Next c

End Sub

Answer 3

对于VBA答案，我会提出类似建议：

Public Function GetPriceOnEachYear(source As Range, prices As Range) As Object()

Dim rng As Range

Dim answer() As Object

last = 0

For Each rng In source

    If Month(rng.Value) = Month(Now) And Day(rng.Value) = Day(Now) Then
        rowdiff = rng.Row - source.Row
        columndiff = rng.Column - source.Column
        ReDim Preserve answer(0 To last)
        Set answer(last) = prices(rowdiff + 1, columndiff + 1)
        last = last + 1
    End If

Next rng

GetPriceOnEachYear = answer

End Function

我没有任何类型安全性，答案是一个范围数组，如果您只想要该值，则可以使用Set answer(last) = prices(rowdiff + 1, columndiff + 1)代替answer(last) = prices(rowdiff + 1, columndiff + 1)。