1

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

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

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

有任何想法吗？

4

1 回答 1

0

以下代码应该很接近 - 根据需要进行调整。它不是为了提高效率而写的——除非你有成千上万的项目要复制，否则这将“完全没有时间”。该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例如，在复制之前清除标签下方的所有空间，这样就不会留下旧值）。在“真实”代码中，您将添加错误处理等。

不过，这应该可以帮助您。

于 2013-11-14T19:35:45.260 回答