查找参考并将所有匹配答案复制到特定列

Question

我制作了一个日历，其中包含全年的日期，我将用它每月注册新的对象。这个月本身并不重要 - 我只是用月份作为参考来找到正确的日期范围，所以目前看来。

FEB  01/02/2014
FEB  02/02/2014 
FEB  03/02/2014
FEB  04/02/2014
FEB  05/02/2014
MAR  01/03/2014
MAR  02/03/2014
JUN  02/06/2014
Jun  03/06/2014

全年都到位了。我在第一页上有一个详细说明月份的下拉菜单，我想要一个宏，它使用选定的月份作为参考，然后将与该月份相关的所有日期复制到一个单独的列。

有什么想法吗？

Answer 1

以下代码应该关闭 - 根据需要进行调整。它不是为了提高效率而写的 - 除非您有数千个要复制的项目，否则这将“毫不费力”。在更新期间，Application.ScreenUpdating技巧可以阻止屏幕闪烁（并使其更快）。

Option Compare Text

Sub moveStuff()
Dim rLabel As Range
Dim rLabelSource As Range

Dim rDestination As Range
Dim c, L

' first label:
Set rLabel = ActiveWorkbook.Worksheets("source").Range("A2")
' extend all the way down:
Set rLabel = Range(rLabel, rLabel.End(xlDown))

Set rLabelSource = ActiveWorkbook.Worksheets("destination").Range("A1")
Set rLabelSource = Range(rLabelSource, rLabelSource.End(xlToRight))

Application.ScreenUpdating = false

' labels in the top row:
For Each L In rLabelSource.Cells
' write results in the next row down:
  Set rDestination = L.Offset(1, 0)
  For Each c In rLabel.Cells
    If c.Value = L.Value Then
      rDestination.Value = c.Offset(0, 1).Value
      Set rDestination = rDestination.Offset(1, 0)
    End If
  Next c
Next L

Application.ScreenUpdating = true

End Sub

在这种情况下，日期和标签位于名为“source”的工作表中：

目标表单（顶行中有标签，复制日期显示在它们下面）名为“目的地”：

显然有很多方法可以使它更干净（在复制之前清除destination中标签下方的所有空间，因此不会遗留旧值）。在“真实”代码中，您将添加错误处理等。

这应该让你顺利。