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

我已经制作了一个日历，并且每年都会使用日期来注册新对象。月份本身并不重要 - 我只是使用月份作为参考来查找正确的日期范围，因此目前看起来如此。查找参考并将所有匹配答案复制到特定列

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

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

任何想法？

来源

2013-11-14 user2993359

这两个单独的列吗？换句话说 - “FEB”是一列，“01/02/2014”是另一列？你有什么问题：找到'FEB'值，找到相应的日期，复制它们，或粘贴它们？你有没有试图记录一个宏让你开始？这通常是一个很好的方法来获得一个粗略的想法... – Floris

是的，他们是两个单独的列，基本上我想选择和复制具有相同参考的所有日期。我正在尝试使用过滤器并记录它，但我不确定在更改日期时它会保持通用 – user2993359

下面的代码应该是关闭的 - 根据需要进行调整。这不是为了提高效率而写的 - 除非你有数千个要复制的项目，否则这将需要“毫无时间”。这个技巧会在更新过程中阻止屏幕闪烁（并使其更快）。

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

在这种情况下，日期和标签是在被称为“源”在片材：

enter image description here

和目的地片（与顶行中的标记，并复制日期出现在它们下面）在片被称为“目标”：

enter image description here

显然，有许多方法可以使这种清洁剂（例如，在复制之前清除destination中标签下的所有空间，因此不会留下旧值）。而在“真实”的代码中，你会添加错误处理等。

这应该让你去。

来源

2013-11-14 19:35:45 Floris

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

回答

相关问题