أكاديمية الصقر للتدريب

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


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه

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


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


23-10-2020 12:00 صباحا
abouelhassan
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-05-2020
رقم العضوية : 19295
المشاركات : 184
الجنس : ذكر
يتابعهم : 6
يتابعونه : 0
قوة السمعة : 418
 offline 

السلام عليكم الاخوة الافاضل والاخوات
هذا الكود من ابداع الاستاذ ياسر موجود بالمنتدى
الكود يقوم بالترحيل عن طريق اختيار من القائمة المنسدلة
احتاج لتغير الخلية F2 لتكون لاختيار الصفحة حيث انها الان نختار منها العمود المراد الترحيل اليه
وتغير القوائم بالعمود E لتكون هى التى نختار منها الاعمدة المراد الترحيل اليها

Sub Test()
    Dim x, ws As Worksheet, sh As Worksheet, sName As String, r As Long, m As Long, n As Long, rng As Range
        Set rng = Sheet1.Range("A2")
    If rng.Value = "" Then MsgBox "اكتب التاريخ من فضلك", vbExclamation: Exit Sub
    'إيقاف اهتزاز الشاشة
    Application.ScreenUpdating = False
        'ورقة العمل المسماة صفحة الترحيل
        Set ws = Sheet1
        'المتغير لمعرفة رقم آخر صف به بيانات في العمود الثاني
        m = ws.Cells(Rows.Count, "B").End(xlUp).Row
        'حلقة تكرارية من الصف رقم 3 إلى آخر صف به بيانات
        For r = 3 To m
            'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
            sName = ws.Cells(r, 5).Value
            'التأكد من وجود ورقة العمل التي سيتم الترحيل إليها
            If Evaluate("ISREF('" & sName & "'!A1)") Then
                'تعيين ورقة العمل التي سيتم الترحيل إليها
                Set sh = ThisWorkbook.Worksheets(sName)
                'تحديد أول صف فارغ في ورقة العمل المراد الترحيل إليها لوضع البيانات بها
                n = sh.Cells(Rows.Count, 1).End(xlUp).Row + 1
                With sh
                    'ترحيل التاريخ
                    .Cells(n, 1).Value = ws.Cells(2, 1).Value
                    'ترحيل الاسم
                    .Cells(n, 2).Value = ws.Cells(r, 2).Value
                    'ترحيل رقم الفاتورة
                    .Cells(n, 3).Value = ws.Cells(2, 3).Value
                    'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
                    x = Application.Match(ws.Cells(2, 6).Value, sh.Rows(1), 0)
                    If Not IsError(x) Then
                        .Cells(n, x).Value = ws.Cells(r, 4).Value
                    End If
                End With
            Else
                Debug.Print "Worksheet " & sName & " Doesn't Exist"
            End If
        Next r
    'استعادة خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
            Range("A3:f24").ClearContents

    MsgBox "تم الترحيل بنجاح", 64, ""

End Sub

مع الشكر والتقدير والاحترام
 
 
  تصميم صفحة.xlsm   تحميل xlsm مرات التحميل :(15)
الحجم :(29.014) KB



أفضل إجابة مقدمة من hassona229 وهي:
وعليكم السلام ورحمه الله وبركاته

بدل السطر



'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
sName = ws.Cells(r, 6).Value

الى

'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
sName = ws.Cells(2, 6).Value


والسطر

'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
x = Application.Match(ws.Cells(2, 5).Value, sh.Rows(1), 0)

الى السطر

'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
x = Application.Match(ws.Cells(r, 5).Value, sh.Rows(1), 0)
عرض الإجابة




23-10-2020 05:15 صباحا
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه
للمرة الألف
لا أحد يعمل على جداول فارغة
قليل فقط من البيانات( 10-15 صف) تكفي لمعرفة ماذا تريد

23-10-2020 06:16 صباحا
مشاهدة مشاركة منفردة [2]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 808
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 11
قوة السمعة : 4330
عدد الإجابات: 113
 offline 
look/images/icons/i1.gif احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه
وعليكم السلام ورحمه الله وبركاته

بدل السطر

  'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
 sName = ws.Cells(r, 5).Value

الى

'متغير لتخزين اسم ورقة العمل التي سيتم الترحيل إليها
sName = ws.Cells(r, 6).Value

والسطر

 'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
x = Application.Match(ws.Cells(2, 6).Value, sh.Rows(1), 0)

الى

  'معرفة رقم العمود الخاص بالمخزن ليتم إدراج المبلغ فيه
 x = Application.Match(ws.Cells(2, 5).Value, sh.Rows(1), 0)


واجعل بياناتات العواميد كما بالصورة

xe6no_col

 
 


23-10-2020 07:42 صباحا
مشاهدة مشاركة منفردة [3]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه
السلام عليكم
إخواني الكرام ممن يقدمون المساعدة
إذا لم يكن الموضوع مستوفي الأركان يرجى تنبيه العضو فإذا لم يستجب يتم إغلاق الموضوع .. الرجاء الالتزام ليظهر المنتدى بشكل لائق ويتم الاستفادة منه بأقصى درجة ، فليس الهدف إكثار الموضوعات والمحتوى بقدر ما أن يكون الهدف الاستفادة الكاملة.

23-10-2020 10:36 صباحا
مشاهدة مشاركة منفردة [4]
abouelhassan
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-05-2020
رقم العضوية : 19295
المشاركات : 184
الجنس : ذكر
يتابعهم : 6
يتابعونه : 0
قوة السمعة : 418
 offline 
look/images/icons/i1.gif احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه
الاساتذة اخواتى الافاضل
اتقدم بالشكر لاستاذى سليم حفظك الله
استاذى حسونة حفظك الله واشكرك للاجابة
استاذ ياسر حفظك الله
اعتذر 
والتمس انى قمت بتحميل هذا الملف من المنتدى هنا كما هو وحاولت تعديله ليلبى طلبى بارك الله فيكم اخواتى
لا حرمنا منكم ابدا
نفذت ما تقدم به الاستاذ حسونة وتوقف الكودج فى هذا السطر
         
            If Evaluate("ISREF('" & sName & "'!A1)") Then

شكر وتقدير واحترام
 
 
  تصميم صفحة.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(28.854) KB


23-10-2020 10:41 صباحا
مشاهدة مشاركة منفردة [5]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه
لا داعي للاعتذر أخي العزيز أبا الحسن والكلام ليس موجه لك وحدك إنما الكلام يوجه للجميع بحيث يراعي الجميع هذه النقاط عند طرح الموضوعات
يرجى الإفادة إذا ما كان الحل المقدم من قبل اخونا حسونة أدى الغرض أم لا .. فإذا لم يكن قم بتوضيح المطلوب مرة أخرى وضع ملف مرفق وبه بعض البيانات كما طلب منك أخونا سليم.

23-10-2020 11:27 صباحا
مشاهدة مشاركة منفردة [6]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 808
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 11
قوة السمعة : 4330
عدد الإجابات: 113
 offline 
look/images/icons/i1.gif احتاج تعديل كود من ابداع الاستاذ ياسر وجدته بالمنتدى احتاج تعديل فيه
انظر للصف رقم 37 موجود فيه بيانات احذفها


الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
احتاج ، تعديل ، ابداع ، الاستاذ ، ياسر ، وجدته ، بالمنتدى ، احتاج ، تعديل ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 05:14 صباحا