تعديل كود الحذف

[Mohamed Elamrousy Elgamal]

السلام عليكم ورحمة الله .... اشكر المنتدى العظيم الذي تعلمت منه الكثير ... وجعلة الله علم تنتفعون به ... آآمل من حضراتكم بالتعديل على الكود في الملف المرفق حيث انني اريد مسح صفوف الأستدعاء فقط مثل الصفوف 4 . 6 .8 أو البيانات التي تم إستدعائها فقط حسب النطاق المحدد من a3:n .. وشاكر أهتمامكم.

test.xlsb

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته

لست متأكدا مما تحاول فعله

  جرب هدا

Sub test()
    Dim wsSource As Worksheet, wsPass As Worksheet
    Dim lastRow As Long, i As Long, passRow As Long, Rng As Range
    
    Set wsSource = Sheets("Sheet1")
    Set wsPass = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
    
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    passRow = 4
    
    For i = 3 To lastRow
        If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then
            wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value
            wsPass.Cells(passRow, 1).Value = passRow - 3
            wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat
            passRow = passRow + 2
            If Rng Is Nothing Then Set Rng = wsSource.Cells(i, 1).Resize(1, 14)
            If Not Rng Is Nothing Then Set Rng = Union(Rng, wsSource.Cells(i, 1).Resize(1, 14))
        End If
    Next i
    
    If Not Rng Is Nothing Then Rng.ClearContents
    
    Application.ScreenUpdating = True
End Sub

لحدف الصفوف 

If Not Rng Is Nothing Then
        Rng.Delete Shift:=xlUp
 End If

 

تم تعديل ديسمبر 11 بواسطه محمد هشام.

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركاته

ضف هذا السطر للكود

            wsSource.Cells(i, 1).Resize(1, 14).ClearContents

الكود كاملا

Sub test()
    Dim wsSource As Worksheet
    Dim wsPass As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim passRow As Long
    Dim passCount As Long
        Dim failRow As Long
    Dim wsFail As Worksheet
    Set wsSource = ThisWorkbook.Sheets("Sheet1")
    Set wsPass = ThisWorkbook.Sheets("Sheet2")

    lastRow = wsSource.Cells(wsSource.Rows.Count, "a").End(xlUp).Row
    passRow = 4
    For i = 3 To lastRow
        If InStr(1, LCase(wsSource.Cells(i, "g").Value), "1/6") > 0 Then
            wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value
            wsPass.Cells(passRow, 1).Value = passRow - 3
            wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat ' نسخ التنسيق
            wsSource.Cells(i, 1).Resize(1, 14).ClearContents

            passRow = passRow + 2
  
        End If
    Next i

End Sub

 

[Mohamed Elamrousy Elgamal]

جزاكم الله خيرا ... ولاكن ليس هذا المطلوب .. اريد مسح بيانات Sheet2 واضافة البيانات الجديد .. وتم توضيحة بالملف المرفق ... وأأسف على الازعاج

test.xlsb

[محمد هشام.]

Sub test()
    Dim wsSource As Worksheet, wsPass As Worksheet
    Dim lastRow As Long, i As Long, passRow As Long
    
    Set wsSource = Sheets("Sheet1")
    Set wsPass = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
    Irow = wsPass.Cells(wsPass.Rows.Count, "G").End(xlUp).Row
    
    For j = 4 To Irow Step 2
        wsPass.Range("A" & j & ":N" & j).ClearContents
    Next j
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    passRow = 4
    
    For i = 3 To lastRow
        If InStr(1, LCase(wsSource.Cells(i, "G").Value), "1/6") > 0 Then
            wsPass.Cells(passRow, 1).Resize(1, 14).Value = wsSource.Cells(i, 1).Resize(1, 14).Value
            wsPass.Cells(passRow, 1).Value = passRow - 3
            wsPass.Cells(passRow, 1).NumberFormat = wsSource.Cells(i, 1).NumberFormat
            passRow = passRow + 2
        End If
    Next i
       
    Application.ScreenUpdating = True
End Sub

 

test.xlsb

[Mohamed Elamrousy Elgamal]

بالفعل هو المطلوب ...وجزاك الله خيرا مهندس محمد وزادك الله من فضله وشاكر اهتمامك ...