Code kopiert nicht und fügt bestimmte Zellen in neues Blatt ein VBA

Question

Ich verwende diesen Code, um jede Zeile im Arbeitsblatt "Report2" für den Ausdruck "Chicago" zu überprüfen und alle Zeilen mit "Chicago" in sie zu kopieren und einzufügen neues Blatt. Es funktioniert jedoch nicht. Jede Hilfe auf warum würde geschätzt werden.

Code:

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 

Lassen Sie mich wissen, wenn Sie helfen können. Vielen Dank!

Answer 1

keine Notwendigkeit für einen Helfer („Report2“) Blatt

Sie den entsprechenden Teil der Datenzellen filtern könnte und kopieren Zellen direkt auf „Clean“ Blatt ausgewählt als

folgt

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