VBA-修改代码从复制粘贴到目标
我的代码运行速度非常慢，我正在试图固定它。 我能想到的唯一方法是没有最后一点的代码复制，select，粘贴两个不同的目标工作表。 想知道是否可以将其更改为Destination：= ____＆____而不是select并粘贴两次？
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 (ie 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 像下面的东西应该可以更改为复制 – 目的地。
range2.Resize(1, 300).Copy Destination:=Sheets(referencesheetname).Cells(p, 1).Offset(2, 0)
虽然如果你真的想加快你的代码，我会说你需要读入数组的范围，然后在数组上进行处理。 看看这张纸在cpu时间上是昂贵的，select应尽可能避免
您也可以closures计算，只需在您需要时重新计算。 你也可以查找“WITH”，因为这些可以加快一点