كتابة كود ترحيل

[نور وحيد]

تحية عطرة لكل عمالقة المنتدى لمساهمتهم الفعالة فى نشر تعلم الاكسل بين الهواة من امثالى وفى ايجاد الحلول العبقرية التى تدل على التمكن و الخبرة وفى النهاية ارجو المساعدة فى تحقيق المطلوب بالملف المرفق

                                                              وشكرا                                                   

الترحيل الى صفحات مختلفة.rar

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

الأخ الفاضل نور وحيد

جرب المرفق التالي ..

آخر سطر بالكود قمت بوضع تعليق عليه وهو خاص بمسح المحتويات بعد عملية الترحيل

 

Transfer Data To Different Sheets.rar

[نور وحيد]

الشكر العظيم على هذا الكود الجميل 

الا ان سطر مسح الفاتورة لا يعمل فبعد الترحيل سواء لصفحة المبيعات او المشتروات تظل بيانات الفاتورة موجودة بما لا يسمح بكتابة فاتورة اخر

واذا اتسع صدرك لى فلو امكن شرح الكود و توضيح ما بهى من الغاز بالنسبى لى

                                                                                                                وشكرا

[ياسر أحمد الشيخ]

بعد اذن الأخ ياسر خليل

تفضل أخى قم بنسخ الكود التالى وضعه فى الملف فى محرر الأكواد قبل السطر End Sub

Range("B3:H100").ClearContents

وشكرا

[سليم حاصبيا]

 بعد اذن اخي و حبيبي ياسر 

تعديل بسيط على الكود الذي قام بوضعه

Transfer Data To Different Sheets salim.rar

[نور وحيد]

فعلا مسح الفاتورة الاصلية تم لو امكن شرح الكود

[نور وحيد]

انا كنت تايه فى كود الان اصبحوا كودين          

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

الأخ الفاضل نور وحيد (وبعدين إزاي وحيد وإنت في منتدى أوفيسنا)

أشرت إليك أنني وضعت تعليق على آخر سطر بالكود قبل نهاية End Sub فقط ليتم تفعيله قم بإزالة علامة Apostrophe اللي في أول السطر .. عشان يكون السطر فعال

WS.Range("B3:H100").ClearContents

بالنسبة للشرح .. هل تحتاج إلى معرفة الأجزاء المراد التعديل عليها أم معرفة كل أسطر الكود

[نور وحيد]

لو امكن و مكنش فية اساءه الكود كلة

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

أخي الفاضل نور (اللي مش وحيد) ..

إن كان حبيبك ياسر غلس عليه براحتك ، وكله كله (جناس تام)

إليك الشرح لعله يفيدك

Sub Tarhil()
    'تعريف المتغيرات
    Dim LR As Long
    Dim X, Y, Z, I As Long
    Dim WS As Worksheet, SHSales As Worksheet, SHPurchases As Worksheet
    'لورقة العمل المسماة الفاتورة[WS]تعيين المتغير المسمى
    'لورقة العمل المسماة المبيعات[SHSales]تعيين المتغير المسمى
    'لورقة العمل المسماة المشتروات[SHPurchases]تعيين المتغير المسمى
    Set WS = Sheets("الفاتورة"): Set SHSales = Sheets("المبيعات"): Set SHPurchases = Sheets("المشتروات")
    
    
    'في حالة حدوث خطأ في سطر ما ينتقل للسطر التالي
    On Error Resume Next
    'تعيين آخر صف به بيانات في ورقة العمل المسماة الفاتورة في العمود الثاني
    LR = WS.Cells(Rows.Count, 2).End(xlUp).Row
    
    'قيمتها تساوي كلمة مبيعات يتم تنفيذ الأسطر التالية[G1]إذا كانت الخلية
    If WS.Range("G1").Value = "مبيعات" Then
        'رسالة تفيد بأن عملية الترحيل ستتم لورقة العمل المبيعات
        MsgBox "سيتم الترحيل إلى ورقة العمل مبيعات"
        'حلقة تكرارية من الصف رقم 3 إلى آخر صف
        For I = 3 To LR
            'يحمل رقم عملية البحث عن العميل الموجود اسمه في العمود السابع ، ويتم البحث في الصف الأول من ورقة المبيعات[X]المتغير
            X = Application.WorksheetFunction.Match(WS.Cells(I, 7).Value, SHSales.Rows(1), 0)
            'يحدد آخر صف به بيانات في ورقة العمل المبيعات تبعاً للعمود الموافق لعملية البحث[Y]المتغير
            Y = SHSales.Cells(Rows.Count, X).End(xlUp).Row + 1
            'نسخ العمود الأول من ورقة الفاتورة لورقة المبيعات
            WS.Cells(I, 1).Copy SHSales.Cells(Y, X)
            'نسخ الأعمدة بداية من العمود رقم 3 إلى العمود رقم 8 في الفاتورة إلى ورقة المبيعات
            WS.Range(Cells(I, 3), Cells(I, 8)).Copy SHSales.Cells(Y, X + 1)
        Next I
    'أما إذا كانت الخلية قيمتها كلمة مشتروات يتم تنفيذ الأسطر التالية
    ElseIf WS.Range("G1").Value = "مشتروات" Then
        'رسالة تفيد بأن عملية الترحيل ستتم لورقة العمل المشتروات
        MsgBox "سيتم الترحيل إلى ورقة العمل مشتروات"
        'حلقة تكرارية من الصف رقم 3 إلى آخر صف
        For I = 3 To LR
            'يحدد آخر صف به بيانات في ورقة العمل المشتروات في العمود الأول + 1[Z]المتغير
           Z = SHPurchases.Cells(Rows.Count, 1).End(xlUp).Row + 1
            'نسخ العمود الأول من ورقة الفاتورة لورقة المشتروات
           WS.Cells(I, 1).Copy SHPurchases.Cells(Z, 1)
            'نسخ الأعمدة بداية من العمود رقم 3 إلى العمود رقم 8 في الفاتورة إلى ورقة المشتروات
           WS.Range(Cells(I, 3), Cells(I, 8)).Copy SHPurchases.Cells(Z, 2)
        Next I
    End If
    'مسح النطاق الذي يحتوي على بيانات الفاتورة
    WS.Range("B3:H100").ClearContents
End Sub

[نور وحيد]

الف شكر جعلة الله فى ميزان حسناتك

أميييييييييييييييييييييييييييييييييييييييييييييييييييييييييييييييين