اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر

السلام عليكم ورحمة الله .... اشكر المنتدى العظيم الذي تعلمت منه الكثير ... وجعلة الله علم تنتفعون به ... آآمل من حضراتكم بالتعديل على الكود في الملف المرفق حيث انني اريد مسح صفوف الأستدعاء فقط مثل الصفوف 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

 

تم تعديل بواسطه محمد هشام.
  • Like 1
قام بنشر

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

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

            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

 

  • Like 1
  • Thanks 1
  • تمت الإجابة
قام بنشر
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

  • Like 3

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information