刚开始学习VBA,试图让我的新工作变得更轻松。我基本上试图查找列E具有字母“a”副本的每个实例并将其粘贴到新创建的名为“Aton”的工作表中,然后使用“a”删除原始行。
我试图修改这里找到的解决方案:VBA: Copy and paste entire row based on if then statement / loop and push to 3 new sheets
当我改变上面的解决方案使这行“如果wsSrc.Cells(i,”E“)。值=”a“然后”那是我遇到问题的时候。
Sub Macro3()
'Need "Dim"
'Recommend "Long" rather than "Integer" for referring to rows and columns
'i As Integer
Dim i As Long
'Declare "Number"
Dim Number As Long
'Declare a variable to refer to the sheet you are going to copy from
Dim wsSrc As Worksheet
Set wsSrc = ActiveSheet
'Declare a variable to refer to the sheet you are going to copy to
Dim wsDest As Worksheet
'Declare three other worksheet variables for the three potential destinations
Dim wsEqualA As Worksheet
'Create the three sheets - do this once rather than in the loop
Set wsEqualA = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'Assign the worksheet names
wsEqualA.Name = "Aton"
'Determine last row in source sheet
Number = wsSrc.Cells(wsSrc.Rows.Count, "C").End(xlUp).Row
For i = 1 To Number
'Determine which destination sheet to use
If wsSrc.Cells(i, "E").Value = "a" Then
Set wsDest = wsEqualA
Else
End If
'Copy the current row from the source sheet to the next available row on the
'destination sheet
With wsDest
wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
End With
'Delete row if column E has an a
If wsSrc.Cells(i, "E").Value = "a" Then
Selection.EntireRow.Delete
Else
End If
Next i
End Sub
坚持你的代码,你有三个问题
把它们放在一起这里是正确的相关片段;
Set wsDest = wsEqualA 'set target sheet once and for all outside the loop
For i = Number To 1 Step -1 'Loop backwards
If wsSrc.Cells(i, "E").Value = "a" Then
'Copy the current row from the source sheet to the next available row on the destination sheet
With wsDest
wsSrc.Rows(i).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) 'Copy wsSrc current “i” row and paste it to wsDest
wsSrc.Rows(i).Delete 'Delete wsSrc current “i” row
End With
End If
Next
作为一种可能的增强,您可以在“With ... End With”块中交换工作表引用,因为引用大多数“已使用”的工具更有效:
With wsSrc
.Rows(i).Copy wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) 'Copy wsSrc current “i” row and paste it to wsDest
.Rows(i).Delete 'Delete wsSrc current “i” row
End With
您需要限定原始值所在的工作表。将Sheet
行上的Set ws = ThisWorkbook.Sheets("Sheet1")
更改为您的工作表名称。
LoopRange
(E2到列中的最后一行)LoopRange
。如果符合条件,则将单元格MyCell
添加到单元格集合(TargetRange
)TargetRange
不为空(意味着您的标准至少满足一次),则将标题从ws
复制到ns
TargetRange
从ws
复制到ns
TargetRange
删除ws
如果使用Union
来收集细胞的好处是你避免了copy/paste/delete
的许多迭代。如果您的范围内有50个符合您标准的单元格,那么copy/paste/delete
将有50个单元格,总共150个操作。
使用Union
方法,每个动作只有1个实例,总共3个动作,这将增加运行时间。
Option Explicit
Sub Learning()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim ns As Worksheet: Set ns = Worksheets.Add(After:=(ThisWorkbook.Sheets.Count)) 'ns = new sheet
ns.Name = "Aton"
Dim LoopRange As Range, MyCell As Range, TargetRange As Range
Set LoopRange = ws.Range("E2:E" & ws.Range("E" & ws.Rows.Count).End(xlUp).Row)
For Each MyCell In LoopRange 'Loop through column E
If MyCell = "a" Then
If TargetRange Is Nothing Then 'If no range has been set yet
Set TargetRange = MyCell
Else 'If a range has already been set
Set TargetRange = Union(TargetRange, MyCell)
End If
End If
Next MyCell
Application.ScreenUpdating = False
If Not TargetRange Is Nothing Then 'Make sure you don't try to copy a empty range
ws.Range("A1").EntireRow.Copy ns.Range("A1") 'copy header from original sheet
TargetRange.EntireRow.Copy ns.Range("A2")
TargetRange.EntireRow.Delete
Else
MsgBox "No cells were found in Column E with value of 'a'"
End If
Application.ScreenUpdating = True
End Sub
首先,不要使用ActiveSheet
,它可能会导致多个问题。如果sheet1
不是您的源工作表,那么更改它以满足您的需求。我更喜欢使用过滤器,正如urdearboy建议的那样,它不需要循环并且速度更快。我总是尽量保持代码简单,所以试试这个......
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Aton"
With Sheet1.UsedRange
.AutoFilter Field:=5, Criteria1:="a", Operator:=xlFilterValues
.Offset(1).SpecialCells(xlCellTypeVisible).Copy Sheets("Aton").Range("A1")
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
.AutoFilter
End With