Question

我有一个VBA脚本，用于搜索带有日期的列中的一系列特定日期（来自AparSheet），并查找早于当前下个月的日期，然后查找源的下个月的日期date，存储在源工作表（WintelSheet）中，并复制整个数据行，其中包含生成的Sheet（从AparSheet复制到GeneratedSheet）范围内的日期。整个过程大约需要40多分钟，虽然有大量数据，但这非常耗时且效率低下。起初，我正在尝试使用过滤器，但我的VBA脚本无法使用过滤器代码。所以我只是简单地使用if语句。我想知道如何修改代码以使其运行更快，我已经清除了脚本末尾的数据，并在脚本开始时关闭了屏幕更新。是否还有其他方法可以修改我的脚本，例如优化代码中的登录？（在Filter by a range of months in VBA使用过滤功能的另一个问题）

供测试的文件：http://www.filedropper.com/samplefortesting

这是我的剧本：

Sub Paste_Dates()

    Dim WintelSheet As Worksheet, _
    GeneratedSheet As Worksheet, _
    AparSheet As Worksheet, _
    wkbSourceBook As Workbook, _
    wkbCrntWorkBook As Workbook, _
    worksheetName As String, _
    Default As String
    Dim wSlastRow As Long
    Dim wSLastPasteRow As Long 'This will be used to check how far down has been copied thus far
    Dim X As Integer, Y As Integer
    Dim NumberOfPasteRows As Long 'This will store how many months there are between dates, to paste into
    Dim PasteCounter As Integer
    Dim dtStart As Date, dtFinal As Date

    Application.ScreenUpdating = False

    Set wkbCrntWorkBook = ActiveWorkbook
    '// Set here Workbook(Sheets) names
    Set GeneratedSheet = wkbCrntWorkBook.Worksheets("APAR Hostname List")
    Set AparSheet = wkbCrntWorkBook.Worksheets("SG APAR")
    wSLastPasteRow = 2
    'extract data from another excel file
    With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xls"
    .AllowMultiSelect = False
    .Show

    If .SelectedItems.Count > 0 Then

        'Prompts user to choose which Worksheet they want to copy from
        MSG1 = MsgBox("Do you wish to copy from 'July CEP Server Patch Tracker' ?", vbYesNo, "Name of Worksheet")
        If MSG1 = vbYes Then
            worksheetName = "July CEP Server Patch Tracker"
        Else
            Default = "Sheet"
            worksheetName = Application.InputBox("Enter the name of Worksheet (Case-sensitive)", Default, Default)
        'End of first If statement
        End If

        Set wkbSourceBook = Workbooks.Open(.SelectedItems(1))
        Set WintelSheet = wkbSourceBook.Sheets(worksheetName)

        With WintelSheet

        '//Find the last row of hostname in column A in WintelSheet
        wSlastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        '//Find the last row of APAR No. in column J in AparSheet
        NumberOfPasteRows = AparSheet.Range("J" & .Rows.Count).End(xlUp).Row
        '//Loop through each hostname in WintelSheet
            For X = 2 To wSlastRow
            '// W is the column with patch release date/PATCHED TILL
            If Not IsError(.Range("W" & X).Value) Then
                If IsDate(.Range("W" & X)) Then
                '//Calculate the last day of the month for dates in Column W (dtStart) and first day of the next current month (dtFinal)
                dtStart = DateSerial(Year(.Range("W" & X)), Month(.Range("W" & X)) + 1, 1)
                dtFinal = DateSerial(Year(Now), Month(Now) + 1, 1)
                'Loop though every rows from row 2 in AparSheet to copy rows with dates in range and put hostname in these rows
                For Y = 2 To NumberOfPasteRows
                With AparSheet
                'Find the dates which earlier then dtFinal latter than dtStart
                If .Range("L" & Y).Value >= DateValue(dtStart) And .Range("L" & Y).Value < DateValue(dtFinal) Then
                    'column A is the hostname list in WintelSheet
                        .Range("A" & Y).EntireRow.Copy Destination:=GeneratedSheet.Range("A" & wSLastPasteRow).EntireRow
                        WintelSheet.Range("A" & X).Copy Destination:=GeneratedSheet.Range("B" & wSLastPasteRow)
                        wSLastPasteRow = wSLastPasteRow + 1

                End If
                End With
                Next Y
                End If
            End If
            Next X

        End With
        wkbSourceBook.Close False
    End If
    End With

    'Free objects
    Set wkbCrntWorkBook = Nothing
    Set GeneratedSheet = Nothing
    Set wkbSourceBook = Nothing
    Set WintelSheet = Nothing
    Set AparSheet = Nothing

    Application.ScreenUpdating = True

    '// Simple Msg Box
    MsgBox "Copy & Paste is Done."
End Sub

以下是所请求的示例数据的几个屏幕截图。

WintelSheet：

AparSheet：

GeneratedSheet：

Answer 1

对现有代码的一些建议：

移动With AparSheet一行，因此很少会运行
DateValue转换是一个额外的步骤，不会影响输出，删除它们只需使用：.Range("L" & Y).Value >= dtStart And .Range("L" & Y).Value < dtFinal
当你使用＆＃34; L＆＃34;经常在ApartSheet栏中声明：set columnL =ApartSheet.Range("L1:L" & NumberOfPasteRows)
在您的代码中可能不太重要，但尝试存储计算结果而不是多次计算
- 从循环中移出dtFinal = DateSerial(Year(Now), Month(Now) + 1, 1)
- 将dtStart存储在数组中
如果您在任何工作表中有任何计算，请在宏的开头关闭它们，然后在它Application.Calculation = xlCalculationManual

但是我同意这些意见，即通过改变代码的逻辑可以实现重大改变。

Answer 2

为了提高性能，有必要减少单元格读取次数（读取列到数组），并最大化一次复制的范围大小。

生成输出列表：

按日期升序排序主机表

按日期升序排序APAR表

创建输出表

将所有三张照片传递给以下程序

Sub CopyRows(shHosts  As Worksheet, shApar As Worksheet, shOutPut As Worksheet)
    Dim vApar As Variant, vHosts As Variant
    Dim iRows As Long, iOffset As Long
    Dim i As Integer, j As Integer
    Dim dMaxDate As Date

    On Error GoTo CleanUp

    Application.ScreenUpdating = False

    iRows = shApar.Range("J" & shApar.Rows.Count).End(xlUp).Row
    vApar = shApar.Range("L2:L" & iRows).Value2

    For i = 1 To iRows - 1
      vApar(i, 1) = vApar(i, 1) - Day(vApar(i, 1)) + 1
    Next

    iRows = shHosts.Range("W" & shHosts.Rows.Count).End(xlUp).Row
    vHosts = shHosts.Range("W2:W" & iRows).Value2

    dMaxDate = DateSerial(Year(Date), Month(Date) + 1, 1)
    j = 1
    iOffset = 0
    For i = 1 To UBound(vApar)
      If vApar(i, 1) >= dMaxDate Then Exit For
      While j < UBound(vHosts) And vHosts(j, 1) < vApar(i, 1)
        j = j + 1
      Wend

      If j > 1 Then
         shApar.Range(i+1 & ":" & i+1).Copy
         shOutPut.Range("2:2").Offset(iOffset, 0).Resize(j).PasteSpecial xlPasteValues
         shOutPut.Range("b2:b2").Offset(iOffset, 0).Resize(j).Value2 = shHosts.Range("a2:a" & j+1).Value2
         iOffset = iOffset + j
      End If
    Next i

CleanUp:
    Application.ScreenUpdating = True

End Sub

在样品表123中，在0.9秒内产生410行。

Answer 3

我认为提高效率的一种方法是Union你的范围，直到你遇到一个你采取行动的条件。我对一个工作簿进行了这一小改动，该工作簿删除了24行中的23行，包含数千行的24小时数据。如果不是更长的话，过程将需要5分钟;改变之后......在瞬间完成。

更快地运行VBA以搜索列表中的一系列日期

3 个答案: