Question

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

我的目标是从单元格A1开始，遍历A列中的每一条记录，同时寻找特定值＆＃34; Gray＆＃34;。如果单元格中的文本等于＆＃34; Gray＆＃34;然后我想将整个行剪切并粘贴到新创建的工作表中，从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")

错误说：

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

任何人都知道为什么？

Answer 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。

Answer 2

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

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

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

2 个答案: