پاک کردن ردیف با شرط

[ali.b]

با سلام
من ی سری ردیف دارم که میخوام فقط اون ردیف هایی که در ستون d متن نمی باشد اومد اون ردیف رو پاک کنه

اخطار: این یک موضوع قدیمی است به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

[mokaram]

نحوه کار را میشه بیشتر باز بکنید
شما نوشته هاتون آماده هست بعد می خواهید این شرط اعمال بشه یا نه همون موقع که زدید مجاز نیست بعد اینتر زدید عمل حذف شدن انجام بشه یا شایدم طور دیگه ؟

[Javid Mokhtari]

با سلام
من ی سری ردیف دارم که میخوام فقط اون ردیف هایی که در ستون d متن نمی باشد اومد اون ردیف رو پاک کنه

با سلام.
خ

Public rw As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
rw = Target.Address
If Sheet1.Range(rw).Column = 4 And Sheet1.Range(rw).Row > 1 And Sheet1.Range(rw).Value = "äãì ÈÇÔÏ" Then
Rows(Sheet1.Range(rw).Row).Delete Shift:=xlUp
End If
End Sub 

[mokaram]

با تشکر از آقا جاوید
اگه کد بالا را به شکل زیر بنویسیم همون موقع جواب میده ( البته کد که همونه فقط ایونتش فرق کرده )
البنه بهتره که کلمه نمی باشد را به یه خونه ربطش بدیم اینطوری نتیجه بهتری می گیریم

Public rw As String

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
rw = Target.Address
If Sheet1.Range(rw).Column = 4 And Sheet1.Range(rw).Row > 1 And Sheet1.Range(rw).Value =sheet1.range("h1").value Then
Rows(Sheet1.Range(rw).Row).Delete Shift:=xlUp
End If
End Sub 

[ali.b]

با سلام
میخوام بعد اینکه می باشد ها به شیت بعدی رفتن خودکار نمی باشد ها هم حذف بشن

[Amir Ghasemiyan]

خب دوستان با توضيحاتي كه دوستمون برام دادن متوجه شدم كدهايي كه شما اساتيد قرار دادين كارشون رو راه نميندازه
ايشون ميخوان سطرهايي كه عبارت «مي باشد» داره رو به شيت ديگه اي منتقل كنن و از شيت مبدا حذف كنن، ولي نه بطور اتومات بلكه با زدن يك دكمه

خب دوست عزيز كدهاي مورد نياز شما اينا هستن. كدهاي خودتون رو پاك كنيد و اينا رو جايگزين كنين:

Sub amir()
Dim cel As Range
Application.ScreenUpdating = False
For Each cel In Range("D:D")
    If cel.Value = "" Then
        w = cel.Row
        Exit For
    End If
    If cel.Row > 2 And cel.Value = Range("D2").Value Then
        Sheet1.Select
        Rows(cel.Row).Copy
        Sheet2.Select
        If Range("A3").Value = "" Then
            Rows("3:3").Insert Shift:=xlDown
        ElseIf Range("A4").Value = "" Then
            Rows("4:4").Insert Shift:=xlDown
        Else
            Range("A3").End(xlDown).Select
            ActiveCell.Offset(1, 0).Range("A1").Select
            Rows(Selection.Row).Insert Shift:=xlDown
        End If
    End If
Next cel
Sheet1.Select
While 1
flag = 1
For i = 3 To w
    If Range("D" & i).Value = Range("D2").Value Then
        Rows(Range("D" & i).Row).Delete Shift:=xlUp
        flag = 0
    End If
Next i
If flag = 1 Then Exit Sub
Wend
Application.ScreenUpdating = True
End Sub

فايل نمونه هم پيوست كردم مشاهده بفرماييد