الرجاء المساعدة في عمل كود نسخ

[hajeer04]

الرجاء المساعدة في عمل كود نسخ لتصفيه جروبين كل جروب في جدول .

المعطيات: الصفحة الرئيسيه تحتوي على جدولين مخلتفين فيهم بيانات مختلفة باسماء العملاء وارقم المعاملات والمبلغ والوحدة والسعر والمجموع والرسوم .الصفحة الرئيسيه تحتوي على جدولين   الجدول الاول (الازرق) فيه بيانات لبضاعه مختلفة عن البضاعة في الجدول التاني (الاحمر) وكلاهما يحتوي على   نوعين من العملاء ABC and DEF المطلوب :
عمل كود لنسخ البيانات الموجودة  بعد تصفيه العملاء في الجدولين  الرئيسيين  الى الجدولين في الصفحة الثانية والصفحة الثالثه بحيث يكون العملاء  ABC في الصفحة الثانيه  والعملاء DEF في الصفحة الثالثه  .

ارجو من لديه المعرفه ان يقدم المساعدة وله جزيل الشكر 

وكل عام وانتم بخير 

الملف في المرفق

test.rar

[ياسر خليل أبو البراء]

السلام عليكم

جرب الكود التالي لعله يفي بالغرض إن شاء الله

Sub Test()
    Dim arr         As Variant
    Dim temp1       As Variant
    Dim temp2       As Variant
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim l           As Long

    arr = Sheet1.Range("A3").CurrentRegion.Value
    ReDim temp1(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    ReDim temp2(1 To UBound(arr, 1), 1 To UBound(arr, 2))

    For i = 2 To UBound(arr, 1)
        If arr(i, 2) = "ABC" Then
            k = k + 1
            For j = 1 To UBound(arr, 2)
                temp1(k, j) = arr(i, j)
            Next j
        End If
        If arr(i, 2) = "DEF" Then
            l = l + 1
            For j = 1 To UBound(arr, 2)
                temp2(l, j) = arr(i, j)
            Next j
        End If
    Next i

    With Sheets("ABC")
        .Range("A4:I25").ClearContents
        .Range("A4").Resize(k, UBound(arr, 2)).Value = temp1
    End With

    With Sheets("DEF")
        .Range("A4:I25").ClearContents
        .Range("A4").Resize(l, UBound(arr, 2)).Value = temp2
    End With
    '=======================================================
    k = 0: l = 0: Erase arr: Erase temp1: Erase temp2

    arr = Sheet1.Range("M3").CurrentRegion.Value
    ReDim temp1(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    ReDim temp2(1 To UBound(arr, 1), 1 To UBound(arr, 2))

    For i = 2 To UBound(arr, 1)
        If arr(i, 2) = "ABC" Then
            k = k + 1
            For j = 1 To UBound(arr, 2)
                temp1(k, j) = arr(i, j)
            Next j
        End If
        If arr(i, 2) = "DEF" Then
            l = l + 1
            For j = 1 To UBound(arr, 2)
                temp2(l, j) = arr(i, j)
            Next j
        End If
    Next i

    With Sheets("ABC")
        .Range("M4:U25").ClearContents
        .Range("M4").Resize(k, UBound(arr, 2)).Value = temp1
    End With

    With Sheets("DEF")
        .Range("M4:U25").ClearContents
        .Range("M4").Resize(l, UBound(arr, 2)).Value = temp2
    End With
End Sub

 

[hajeer04]

 

 بارك الله فيك وشكرا جزيلا للمساعدة .

عندي استفسار اذا تم ادخال بيانات اخرى جديدة في الجدول الرئيسي بحيث كل يوم تم ادخال 50 عملية هل يستطيع الكود اخد البيانات وتصفيتها الى كل مجموعة .

انا ليس لدي خبرة في مجال الكود .هل اعمل زر كوماند واشبك الكود مع الزر .

[ياسر خليل أبو البراء]

الكود يقوم بمسح الجداول للنتائج أولاً ويعمل من جديد مع كل مرة يتم تنفيذه

نعم يمكن عمل زر أمر وربط الماكرو به

للمزيد حول الأساسيات للتعامل مع محرر الأكواد قم بمشاهدة الفيديو التالي

 

[hajeer04]

الاخ ياسر شكرا جزيلا وبارك الله فيك على المساعدة 

اتمنى لك التوفيق 

[hajeer04]

اخ ياسر سؤال اذا اردت ان اغير اسم الصفحه الثانيه والثالثة من ABC الى retalier1 ,والصفحة الثالثة من DEF الى retalier2 الكود يعطى خطأ رقم 13 ما السبب

[ياسر خليل أبو البراء]

قم بالإطلاع على الكود وغير أسماء أوراق العمل في أسطر الكود ليعمل بشكل صحيح