代码不会将特定的单元格复制并粘贴到新工作表VBA中

Question

我正在使用此代码检查工作表“ Report2”中的每一行是否包含短语“ Chicago”，并将其中包含“ Chicago”的任何行复制并粘贴到新表中。 但是，它不起作用。 任何关于为什么的帮助将不胜感激。

码：

Sub BranchCount()

Dim s As Worksheet
Dim LastRow As Long

Set s = Worksheets("Report 1")
LastRow = s.UsedRange.SpecialCells(xlCellTypeLastCell).Row

Worksheets("Report 1").Select
Range("A1:J" & LastRow).Select
Selection.Copy

Sheets.Add.Name = "Report2"
Selection.PasteSpecial xlPasteValues
Range("A1").EntireRow.Delete
Range("B1").EntireRow.Delete
Range("C1").EntireRow.Delete

Dim Z As Range
Dim Y As String

Y = W
W = "Chicago"

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

For Each Z In Range("J1:J" & LastRow)
    If Y = Z.Value Then
        Z.EntireRow.Copy
            Sheets("Clean").Select
                Range("A700").End(xlUp).Offset(1, 0).Select
                Selection.PasteSpecial xlPasteValues
            Sheets("Report2").Select
    End If
Next

End Sub

让我知道您能否提供帮助。 谢谢！

Answer 1

无需任何帮助（“ Report2”）表

您可以过滤数据单元格的相关部分，然后将所选单元格直接复制到“ Clean”工作表中，如下所示

Option Explicit

Sub BranchCount()

Dim s1 As Worksheet, sC As Worksheet
Dim LastRow As Long

Set s1 = Worksheets("Report 1")
Set sC = Sheets("Clean")

With s1
    LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
    With .Range("A1:J" & LastRow)
        .AutoFilter field:=10, Criteria1:="Chicago"
        With .Offset(1).Resize(.Rows.Count - 1)
            If Application.WorksheetFunction.Subtotal(103, .Columns("J")) > 1 Then .SpecialCells(xlCellTypeVisible).Copy Destination:=sC.Range("A700").End(xlUp).Offset(1, 0)
        End With
        .AutoFilter
    End With
End With

End Sub