根据date复制多次相同的数据

我需要写一个macros来复制主机名和date到另一个工作簿，需要复制的date在B列和AJ作为主机名和date分开：

它应该复制的方式是，如果date是2015年1月，那么我需要复制主机名和date在另一个工作簿5次（意味着有5行相同的数据），自6月（6）减1月（ 1）是5.如果date是2014年12月，那么我需要复制6行主机名和date，因为在12月到6月之间有6个月。

最终结果如下所示：

现在我正在用VBA做什么，这是非常无效的，我不能让macros按预期的方式放置每一个date的行，我也意识到我必须做每年的if语句，所以我想知道如何使其更有效，使macros观运行更快。

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函数来确定date之间有多less个月，像这样[请注意，我指的是范围（“A1”）下面，以代表您将input您的2015年6月date的地方。 如果2015年6月的比较date出现在其他地方，请将范围（“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