تصفية تلقائية

[mustafa khatab]

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

الرجاء المساعدة فى عمل شيت منفضل بتصفية المنتجات حسب الاكسل المرفق .

في حالة وجود بيانات في عمود F يتم ترحيل جميع الاسطر باستثناء الاسطر الفارغة ( في عمود F) الى شيت " النتيجة هنا "

 

 

تصفية تلقائية حسب معطيات محدده.xlsx

[abouelhassan]

جرب

Sub نقل_البيانات()
    Dim ws As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
    Dim i As Long
    
    ' افتح ورقة العمل الحالية
    Set ws = ThisWorkbook.Sheets("Sheet1") ' استبدل "Sheet1" باسم ورقة العمل الخاصة بك
    
    ' قم بإنشاء ورقة النتيجة إذا لم تكن موجودة بالفعل
    On Error Resume Next
    Set wsResult = ThisWorkbook.Sheets("النتيجة هنا")
    On Error GoTo 0
    
    If wsResult Is Nothing Then
        Set wsResult = Sheets.Add(After:=Sheets(Sheets.Count))
        wsResult.Name = "النتيجة هنا"
    End If
    
    ' حساب آخر صف غير فارغ في عمود F
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
    
    ' نقل البيانات إلى ورقة النتيجة باستثناء الأسطر الفارغة في عمود F
    For i = 1 To lastRow
        If ws.Cells(i, "F").Value <> "" Then
            ws.Rows(i).Copy wsResult.Rows(wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1)
        End If
    Next i
    
    MsgBox "تم نقل البيانات بنجاح!"
End Sub

 

[mustafa khatab]

جزاك الله خيرا ,  هل من الممكن اكسل ؟ ليس لدى معرفة فى الاكواد 

[ميدو63]

الاخ الفاضل

الكود يعمل ولكن يرحل نتيجة واحدة فقط وليس كل النتائج

[abouelhassan]

جرب

Sub نقل_البيانات()
    Dim ws As Worksheet
    Dim wsResult As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim nextRow As Long
    
    ' افتح ورقة العمل الحالية
    Set ws = ThisWorkbook.Sheets("Sheet1") ' استبدل "Sheet1" باسم ورقة العمل الخاصة بك
    
    ' قم بإنشاء ورقة النتيجة إذا لم تكن موجودة بالفعل
    On Error Resume Next
    Set wsResult = ThisWorkbook.Sheets("النتيجة هنا")
    On Error GoTo 0
    
    If wsResult Is Nothing Then
        Set wsResult = Sheets.Add(After:=Sheets(Sheets.Count))
        wsResult.Name = "النتيجة هنا"
    End If
    
    ' حساب آخر صف غير فارغ في عمود F
    lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
    
    ' نقل البيانات إلى ورقة النتيجة باستثناء الأسطر الفارغة في عمود F
    nextRow = 1 ' الصف التالي المتاح في ورقة النتيجة
    For i = 1 To lastRow
        If ws.Cells(i, "F").Value <> "" Then
            ws.Rows(i).Copy wsResult.Rows(nextRow)
            nextRow = nextRow + 1
        End If
    Next i
    
    MsgBox "تم نقل البيانات بنجاح!"
End Sub

 

[ميدو63]

اشكرك استاذى الفاضل

واسف على التاخير فى متابعة الموضوع والرد..