Excel在复制/粘贴宏上冻结大约10分钟，更有效的方式？
Excel在复制/粘贴宏上冻结大约10分钟，更有效的方式？
提问于 2018-08-21 11:41:12
我在使用excel VBA宏时遇到了一个问题，代码的执行部分有时会运行超过8-10分钟。我已经将其缩小到代码的这一部分，该代码根据行中单元格的值复制并粘贴到另一个工作表。
Sub ChangeTest()
Sheets.Add.Name = "FY16"
Sheets.Add.Name = "FY17"
Sheets.Add.Name = "FY18"
Sheets.Add.Name = "FY19"
'Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("FY SalesLeads")
j = 1 ' Start copying to row 1 in target sheet
k = 1
l = 1
m = 1
For Each c In Source.Range("B1:B8000") ' Do 1000 rows
If c = "A" Then
Set Target = ActiveWorkbook.Worksheets("FY16")
Source.Rows(c.Row).Copy Target.Rows(j)
j = j + 1
ElseIf c = "B" Then
Set Target = ActiveWorkbook.Worksheets("FY17")
Source.Rows(c.Row).Copy Target.Rows(k)
k = k + 1
ElseIf c = "C" Then
Set Target = ActiveWorkbook.Worksheets("FY18")
Source.Rows(c.Row).Copy Target.Rows(l)
l = l + 1
ElseIf c = "D" Then
Set Target = ActiveWorkbook.Worksheets("FY19")
Source.Rows(c.Row).Copy Target.Rows(m)
m = m + 1
End If
Next c
End Sub有没有一种更有效的方法来做这件事而不挂起Excel？我还注意到，在运行宏之后，有时甚至Windows资源管理器也变得没有响应。
感谢大家在这里所做的一切，我爱这个社区！
回答 1
Stack Overflow用户
发布于 2018-08-21 12:44:56
正如Siddharth Rout指出的那样，自动筛选将非常快速地完成您的任务。代码在最后一个工作表之后添加新的工作表。然后，它会根据每个条件自动筛选数据，并将可见数据粘贴到新工作表上的A1中。
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim shtArr As Variant
shtArr = Array("FY16", "FY17", "FY18", "FY19")
Dim i As Long
For i = LBound(shtArr) To UBound(shtArr)
Set ws = Nothing
On Error Resume Next
Set ws = Worksheets(shtArr(i))
On Error GoTo 0
If ws Is Nothing Then
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = shtArr(i)
End If
Next i
Dim Source As Worksheet
Set Source = ThisWorkbook.Worksheets("Sheet1")
With Source.Range("A1").CurrentRegion
.AutoFilter
.AutoFilter Field:=2, Criteria1:="A"
.Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("FY16").Range("A1")
.AutoFilter Field:=2, Criteria1:="B"
.Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("FY17").Range("A1")
.AutoFilter Field:=2, Criteria1:="C"
.Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("FY18").Range("A1")
.AutoFilter Field:=2, Criteria1:="D"
.Cells.SpecialCells(xlCellTypeVisible).Copy _
Destination:=Sheets("FY19").Range("A1")
.AutoFilter
End With
Application.ScreenUpdating = True页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/51941250
复制相关文章
相似问题
腾讯云开发者
