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

【问题标题】：Find Reference and Copy All Matching Answers to a Specific Column查找参考并将所有匹配的答案复制到特定列
【发布时间】：2013-11-14 18:09:26
【问题描述】：

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

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

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

有什么想法吗？

【问题讨论】：

这两列是分开的吗？换句话说 - FEB 是一列，01/02/2014 是另一列吗？您有什么问题：查找FEB 值、查找相应的日期、复制它们还是粘贴它们？您是否尝试过录制宏来帮助您入门？这通常是获得粗略想法的好方法...
是的，它们是两个独立的列，基本上我想选择并复制具有相同参考的所有日期。我正在尝试使用过滤器并记录它，但不确定当我更改日期时它是否会保持通用

标签： excel copy find range vba

【解决方案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

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

还有名为“destination”的工作表中的目标工作表（顶行带有标签，复制的日期显示在其下方）：

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

不过，这应该能让你继续前进。

【讨论】：