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函数来确定日期之间的月份，就像这样[注意我在下面引用范围（“A1”），到代表您键入2015年6月日期的地方。如果2015年6月比较日期出现在其他地方，请将范围（“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

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

1 个答案: