根据日期多次复制相同的数据

Question

我需要编写一个宏将主机名和日期复制到另一个工作簿，需要复制的日期在 B 列和 AJ 中分别作为主机名和日期：

它应该复制的方式是，如果日期是 2015 年 1 月，那么我需要将主机名和日期复制到另一个工作簿上 5 次（意味着有 5 行相同的数据），自 6 月 (6)减去 Jan(1) 是 5。如果日期是 2014 年 12 月，那么我需要复制 6 行主机名和日期，因为从 12 月到 6 月有 6 个月。

最终结果如下图所示：

现在我用 VBA 做的事情放在下面，这是非常无效的，我无法让宏按预期放置每个日期的行，而且我意识到我必须每年都做 if 语句，所以我想知道如何让它更有效，让宏运行得更快。

With wSheet1
    '// Here lets Find the last row of data
    wSlastRow = .Rows(.Range("B:B").Rows.Count).End(xlUp).Row

    '// Now Loop through each row
    For X = 2 To wSlastRow
        'insert wSlastRow no of rows to worksheet Summary
        'wSheet1.Rows(wSlastRow).Insert Shift:=xlDown
        If Not IsError(.Range("AJ" & X).Value) Then
            If IsDate(.Range("AJ" & X)) Then
                If Year(.Range("AJ" & X)) = 2015 Then
                    Do While Month(.Range("AJ" & X).Value) > 7
                        .Range("B" & X).Copy Destination:=wSheet2.Range("B" & X)
                        .Range("AJ" & X).Copy Destination:=wSheet2.Range("J" & X)
                    Loop
                End If
            End If
        End If
    Next X

End With

Answer 1

这里只需要进行一些更改；有更简单的方法可以粘贴多行，但使用您的循环方法，您只需要使用 DATEDIFF 函数来确定日期之间有多少个月，就像这样 [注意我在下面提到 range("A1")代表您输入 2015 年 6 月日期的地方。如果 2015 年 6 月的比较日期出现在其他地方，请将 Range("A1") 更改为其他内容]：

Sub Paste_Dates()

Dim wSlastRow As Integer
Dim wSLastPasteRow As Integer 'This will be used to check how far down has been copied thus far
Dim X As Integer
Dim NumberOfPasteRows As Integer 'This will store how many months there are between dates, to paste into
Dim PasteCounter As Integer

wSLastPasteRow = wSheet2.Rows(Sheets(2).Range("B:B").Rows.Count).End(xlUp).Row

With wSheet1

'// Here lets Find the last row of data
wSlastRow = 10 '.Rows(.Range("B:B").Rows.Count).End(xlUp).Row

'// Now Loop through each row
For X = 2 To wSlastRow

If Not IsError(.Range("AJ" & X).Value) Then
    If IsDate(.Range("AJ" & X)) Then

        NumberOfPasteRows = DateDiff("m", .Range("AJ" & X), .Range("A1"))
        'This finds the difference between your two dates in rounded months, and pastes for that number of rows
        'NOTE: A1 SHOULD BE REPLACED WITH WHATEVER DEFINES THE "JUNE 2015 COMPARISON"

        For PasteCounter = 1 To NumberOfPasteRows

            .Range("B" & X).Copy Destination:=wSheet2.Range("B" & wSLastPasteRow)
            .Range("AJ" & X).Copy Destination:=wSheet2.Range("AJ" & wSLastPasteRow)
            'Note - this used to paste to J; I have adjusted to now post to AJ

            wSLastPasteRow = wSLastPasteRow + 1
        Next PasteCounter

    End If
End If
Next X

End With 
End Sub