VBA代码复制和粘贴某些数据从一个表到另一个

我是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 

Answer 1

我build议使用自动筛选器来筛选出所需的数据，然后使用ActiveSheet.UsedRange.Copy将筛选的数据复制到新工作表中。 另外，当你需要遍历所有的数据，而不是一直到65500转到ActiveSheet.UsedRange.Rows.Count所以你不通过空单元循环。

例：

你有第一个循环看起来像它复制列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 

而不是循环遍历所有的数据，你可以过滤它，并像这样复制结果：

 '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 

也在这里你通过1至65500循环

 For row = 1 To 65500 If Sheets("SCO").Cells(row, 14) = "" Then Sheets("SCO").Cells(row, 20).Value = 2 End If Next 

你可以这样做来减less你需要循环的次数

 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