[英]Execute Time (Select, Copy & Paste in same order for Non Adjacent Cells)
This VBA takes a lot of time to execute这个 VBA 需要很多时间来执行
Sub test()
Dim IB As String
Dim copyRng As Range, cel As Range, pasteRng As Range
With Selection
Set copyRng = Selection
End With
IB = Application.InputBox("Enter Exact Sheet Name to Paste")
Set pasteRng = Sheets(IB).Range("A1")
For Each cel In copyRng
cel.Copy
pasteRng.Range(cel.Address).PasteSpecial xlPasteAll
Next
Application.CutCopyMode = False
End Sub
I've turned off screen updating and replaced looping through cells with looping through areas of the range.我已经关闭了屏幕更新,并用循环遍历范围的区域替换了循环遍历单元格。
When you would only need values to be copied, another (vast) improvement in performance would be to copy by assignment .当您只需要复制值时,性能的另一个(巨大)改进将是通过 assignment 复制。 Then in the loop, you would use the following code:
然后在循环中,您将使用以下代码:
darg.Value = sarg.Value
instead of sarg.Copy darg
.而不是
sarg.Copy darg
。
Option Explicit
Sub CopyNonContiguous()
Const ProcTitle As String = "Copy Non-Contiguous"
Dim srg As Range
If TypeName(Selection) = "Range" Then
Set srg = Selection
Else
MsgBox "Select a range. please.", vbCritical, ProcTitle
Exit Sub
End If
Dim wsName As Variant
wsName = Application.InputBox( _
"Enter Sheet Name to Paste", ProcTitle, , , , , , 2)
If wsName = False Then
MsgBox "You canceled.", vbExclamation, ProcTitle
Exit Sub
End If
Dim dws As Worksheet
On Error Resume Next
Set dws = ActiveWorkbook.Worksheets(wsName) ' consider 'ThisWorkbook'
On Error GoTo 0
If dws Is Nothing Then
MsgBox "The worksheet '" & wsName & "' doesn't exist.", _
vbCritical, ProcTitle
Exit Sub
End If
Application.ScreenUpdating = False
Dim sarg As Range
Dim darg As Range
For Each sarg In srg.Areas
Set darg = dws.Range(sarg.Address)
sarg.Copy darg
Next sarg
Application.ScreenUpdating = True
MsgBox "Cells copied.", vbInformation, ProcTitle
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.