Question

我的代码运行速度非常慢，我试图将其固定。我能想到的唯一方法就是不使用最后一段代码来复制，选择，粘贴两次不同的目标工作表。想知道我是否能够将其改为目的地：= ____＆amp; ____而不是选择和粘贴两次？

    Sub compare()
'compare if the values of two ranges are the same
'Select workbook to prevent mismatch error
Application.ScreenUpdating = False
Application.DisplayStatusBar = False

Workbooks("Compare.xlsm").Activate
    Dim referencesheetname, newsheetname, outputsheetname As String
    referencesheetname = "Reference"
    newsheetname = "New"

    Dim range1, range2 As Range
    'define the variables
    Dim referencesheetcols As Integer
    Dim range1rows, range1cols, range2rows, range2cols, testrows, testcols, i, j, p, q As Long
    Dim bMatches, rowmatched As Boolean
    Dim product As String
    'Define names for easy reference
    product = "Ethylene"
    'Set range you wish the macro to search up till
    newsheetcols = 3000
    referencesheetcols = 3000
    'How many rows and columns should we compare?
    'Set testcols to 150 to test whole range
    testrows = 1
    testcols = 200

    'Set p for position to place data at (i.e. if p=1, data will be pasted)
    p = Sheets(referencesheetname).UsedRange.Rows.Count
    q = Sheets("Datasheet").UsedRange.Rows.Count


    'Pasted table range data starts from row 7
    For l = 1 To newsheetcols
        'ActiveWorkbook.Worksheets(newsheetname).Select
        'only test if correct product down column B
        If CStr(Sheets(newsheetname).Rows(l).Cells(1, 2).Value) = product Then

            rowmatched = False
            For k = 5 To referencesheetcols

                'bmatch = False
                'Define range compare rows 6 onwards for both sheets
                Set range1 = Sheets(referencesheetname).Rows(k)
                Set range2 = Sheets(newsheetname).Rows(l)

                ' count the rows and columns in each of the ranges
                range1rows = range1.Rows.Count
                range1cols = range1.Columns.Count
                range2rows = range2.Rows.Count
                range2cols = range2.Columns.Count

                'Check if ranges are the same dimension?
                bMatches = (range1rows = range2rows And range1cols = range2cols)

                'if same dimensions loop through the cells
                If bMatches Then

                    For i = 1 To testrows
                        For j = 1 To testcols

                            If (range1.Cells(i, j).Value <> range2.Cells(i, j).Value) Then
                                 'Conclude that range dimension is not the same
                                 bMatches = False
                                 i = testrows
                                 j = testcols
                                 'Exit loops
                            End If
                        Next
                    Next
                End If

                'If ranges of two comparison sheets are the same
                If bMatches Then
                    rowmatched = True
                    k = referencesheetcols
                End If

                'Sheets(outputsheetname).Cells(1, 1).Value = rowmatched
                'Set place to paste data
                If (Not (rowmatched) And k = referencesheetcols) Then
                'Copy and paste specified number of columns
                    range2.Resize(1, 300).Copy
                    Sheets(referencesheetname).Cells(p, 1).Offset(2, 0).Select
                    ActiveSheet.Paste
                    p = p + 1
                    Sheets("Datasheet").Activate
                    ActiveSheet.Cells(q, 1).Offset(2, 1).Select
                    ActiveSheet.Paste
                    q = q + 1
                End If
                Next
        End If
    Next

    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True

End Sub

Answer 1

下面的内容应该可以改为复制 - 目的地。

range2.Resize(1, 300).Copy Destination:=Sheets(referencesheetname).Cells(p, 1).Offset(2, 0)

虽然如果你真的想加速代码，我会说你需要将范围读入一个数组，然后对数组进行处理。在cpu时间方面查看表单是昂贵的，应尽可能避免选择

您也可以关闭计算，并在需要时重新计算。您也可以查看＆＃34; WITH＆＃34; s，因为这些可以加快它的速度

VBA-修改代码从复制并粘贴到目标

1 个答案: