السلام عليكم،
بعد إذن الاخ سليم، حل آخر من أجل تعميم الفائدة :
Sub Test()
With Sheet6
.Range("A6:I" & .Cells(.Cells.Rows.Count, "A").End(xlUp).Row).Offset(1).ClearContents
End With
Range("A6:AB100").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Sheet6.Range("W1:W2"), CopyToRange:=Sheet6.Range("A6:I6"), Unique:= _
False
End Sub
ترحيل البيانات اعتمادا على قيمة نصية.rar