用于将某些数据从工作表复制并粘贴到另一个工作表的 VBA 代码
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/17109968/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA code to copy and paste certain data from sheet to another
提问by Daniel YOo
I'm new to VBA and I know there has to be a simpler and more efficient way of writing this code, but not familiar with the correct functions (like how to paste to the next worksheet without pasting over existing data). It works for smaller worksheets but I have to use it on worksheets with 60000+ lines. Any help will be greatly appreciated. Thanks in advance.
我是 VBA 新手，我知道必须有一种更简单、更有效的方式来编写此代码，但不熟悉正确的功能（例如如何粘贴到下一个工作表而不粘贴现有数据）。它适用于较小的工作表，但我必须在 60000 多行的工作表上使用它。任何帮助将不胜感激。提前致谢。
Sub test()
Dim row As Long
With Excel.Application
.ScreenUpdating = False
.Calculation = Excel.xlCalculationManual
.EnableEvents = False
End With
For row = 1 To 65500
If ThisWorkbook.ActiveSheet.Cells(row, 14) <> "" Then
ThisWorkbook.ActiveSheet.Cells(row, 1).EntireRow.Copy
ThisWorkbook.ActiveSheet.Paste Destination:=ThisWorkbook.Sheets("SCO").Cells(row, 1)
ThisWorkbook.ActiveSheet.Cells(row + 1, 1).EntireRow.Copy
ThisWorkbook.ActiveSheet.Paste Destination:=ThisWorkbook.Sheets("SCO").Cells(row + 1, 1)
End If
Next
For row = 1 To 65500
If ThisWorkbook.Sheets("SCO").Cells(row, 14) = "" Then
ThisWorkbook.Sheets("SCO").Cells(row, 20).Value = 2
End If
Next
For x = 65500 To 1 Step -1
If ThisWorkbook.Sheets("SCO").Cells(x, 3) = "" Then
ThisWorkbook.Sheets("SCO").Cells(x, 1).EntireRow.Delete
End If
Next
For row = 1 To 65500
If ThisWorkbook.Sheets("SCO").Cells(row, 20) = 2 Then
ThisWorkbook.Sheets("SCO").Cells(row + 1, 1).EntireRow.Insert shift:=xlDown
End If
Next
With Excel.Application
.ScreenUpdating = True
.Calculation = Excel.xlAutomatic
.EnableEvents = True
End With
End Sub
采纳答案by Ripster
I suggest using an autofilter to filter the data out that you want and then use ActiveSheet.UsedRange.Copyto get copy the filtered data onto a new sheet. Also when you do need to loop through all of your data instead of going all the way to 65500 go to ActiveSheet.UsedRange.Rows.Countso you don't loop through empty cells.
我建议使用自动过滤器过滤出您想要的数据，然后使用ActiveSheet.UsedRange.Copy将过滤后的数据复制到新工作表上。此外，当您确实需要遍历所有数据而不是一直到 65500 时，请转到，ActiveSheet.UsedRange.Rows.Count这样您就不会遍历空单元格。
Example:
例子：
The first loop you have looks like it copies all rows that do not have blanks in column 14.
您拥有的第一个循环看起来像是复制了第 14 列中没有空格的所有行。
For row = 1 To 65500
If ThisWorkbook.ActiveSheet.Cells(row, 14) <> "" Then
ActiveSheet.Cells(row, 1).EntireRow.Copy
ActiveSheet.Paste Destination:=ThisWorkbook.Sheets("SCO").Cells(row, 1)
ActiveSheet.Cells(row + 1, 1).EntireRow.Copy
ActiveSheet.Paste Destination:=ThisWorkbook.Sheets("SCO").Cells(row + 1, 1)
End If
Next
Instead of looping through all of the data you could filter it and copy the result like this:
您可以过滤它并复制结果，而不是遍历所有数据，如下所示：
'Filter out blank rows in column 14
ActiveSheet.UsedRange.AutoFilter Field:=14, Criteria1:="<>"
'Copy and Paste the results to Sheet "SCO"
If Sheets("SCO").Range("A1").Value = "" Then
ActiveSheet.UsedRange.Copy Destination:=Sheets("SCO").Range("A1")
Else
ActiveSheet.UsedRange.Copy Destination:=Sheets("SCO").Cells(Sheets("SCO").UsedRange.Rows.Count, 1)
End If
Also here where you loop through 1 to 65500
也是在这里你循环 1 到 65500
For row = 1 To 65500
If Sheets("SCO").Cells(row, 14) = "" Then
Sheets("SCO").Cells(row, 20).Value = 2
End If
Next
You could do this to reduce the amount of times you need to loop
你可以这样做来减少你需要循环的次数
For row = 1 To Sheets("SCO").UsedRange.Rows.Count
If Sheets("SCO").Cells(row, 14) = "" Then
Sheets("SCO").Cells(row, 20).Value = 2
End If
Next
