循环遍历整列值,如果值匹配,则将其剪切并粘贴到另一个工作表

时间:2017-05-01 19:50:28

标签: excel vba excel-vba

您好我试图在excel中做一些简单的事情,基本上我有数据列A,B,C,D和E.

我的目标是从单元格A1开始,遍历A列中的每一条记录,同时寻找特定值" Gray"。如果单元格中的文本等于" Gray"然后我想将整个行剪切并粘贴到新创建的工作表中,从A1开始。这是我的代码看起来像......

Dim n As Long
Dim nLastRow As Long
Dim nFirstRow As Long
Dim lastRow As Integer

ActiveSheet.UsedRange

Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row

Worksheets("Original").Activate
With Application
.ScreenUpdating = False


Sheets.Add.Name = "NewSheet"

Sheets("Original").Select
Range("A1").Select

Set r = ActiveSheet.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row

With ActiveSheet
    For n = nLastRow To nFirstRow Step -1
        If .Cells(n, "A") = "Grey" Then
            .Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")
            .Cells(n, "A").EntireRow.Delete
            n = n + 1
        End If
    Next
End With

.ScreenUpdating = True
End With

所以这个宏创建了一个新工作表 - 但是当它到达一个灰色值的单元格时,它会在这一行上给我一个错误....

.Cells(n, "A").EntireRow.Cut Sheets("NewSheet").Cells(i, "A")

错误说:

  

应用程序定义或对象定义错误。

任何人都知道为什么?

2 个答案:

答案 0 :(得分:1)

您需要声明i并进行设置。如上所述,它第一次出现时,它希望粘贴在行0中,而这行不存在。

此外,它最适合avoid using .Select/.Activate,并直接处理数据。

这是如何运作的?

Sub t()
Dim r As Range
Dim n       As Long, i As Long, nLastRow As Long, nFirstRow As Long
Dim lastRow As Integer
Dim origWS As Worksheet, newWS As Worksheet

Set origWS = Worksheets("Original")
Set newWS = Sheets.Add
newWS.Name = "NewSheet"

Set r = origWS.UsedRange
nLastRow = r.Rows.Count + r.Row - 1
nFirstRow = r.Row

i = 1

With Application
    .ScreenUpdating = False
    With origWS
        For n = nLastRow To nFirstRow Step -1
            If .Cells(n, "A") = "Grey" Then
                .Cells(n, "A").EntireRow.Copy newWS.Cells(i, "A")
                .Cells(n, "A").EntireRow.Delete
                i = i + 1
            End If
        Next
    End With
    .ScreenUpdating = True
End With
End Sub

你也不需要做n = n + 1(除非我错过了什么)。

修改:根据OP希望保留格式,将.Cut更改为.Copy

答案 1 :(得分:1)

或者您可以尝试这样的事情......

Sub CopyToNewSheet()
Dim sws As Worksheet, dws As Worksheet
Application.ScreenUpdating = False
Set sws = Sheets("Original")
On Error Resume Next
Set dws = Sheets("NewSheet")
dws.Cells.Clear
On Error GoTo 0

If dws Is Nothing Then
    Sheets.Add(after:=sws).Name = "NewSheet"
    Set dws = ActiveSheet
End If
sws.Rows(1).Insert
On Error Resume Next
With sws.Range("A1").CurrentRegion
    .AutoFilter field:=1, Criteria1:="Grey"
    .SpecialCells(xlCellTypeVisible).Copy dws.Range("A1")
    .SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
dws.Rows(1).Delete
Application.ScreenUpdating = True
End Sub