logo

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
Hatem Eissa hassona229-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة اكسيل مشاريع جاهزه



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




اضافة رد جديد اضافة موضوع جديد

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


15-12-2017 12:32 صباحاً
السلام عليكم
MTY3ODkx23132132
نظرا لكثرة الاسئلة عن طريقة الترحيل لاعمدة غير مرتبة ومتفرقة وخلافة من هذه الامور
قمت بعمل ترحيل يناسب اغلب الاخوة في احتياجاتهم
الكود مرن جدا كل ما عليك هو تحديد اسم صفحة ادخال البيانات وصفحة قاعدة البيانات
وارقام اعمدة البداية لادخال البيانات وايضا اول صف به بيانات
وعدد الاعمدة المراد الترحيل منها
والنقطة الاهم والمميزة وهي ترتيب اعمدة صفحة الادخال بما يقابلها من اعمدة قاعدة البيانات
وتستطيع ترك اعمدة بين اعمدة الترحيل بدون الترحيل لها
الكود
CODE
Sub Yasser()
    Dim Add As Worksheet
    Dim Data As Worksheet
    Dim ar1 As Variant
    Dim ar2 As Variant
    Dim arr As Variant
    Dim v As Long, rw, x, xx
    Const co1 As Long = 2 'رقم اول عمود لصفحة ادخال البيانات
    Const co2 As Long = 3  'رقم اول عمود لصفحة قاعدة البيانات
    Const ro1 As Long = 5 'رقم اول صف ترحيل بيانات في صفحة ادخال البيانات
    Const co_num1 As Long = 20 ' عدد الاعمدة المراد الترحيل منها
    Set Add = Sheets("Enter") 'اسم صفحة ادخال البيانات
    Set Data = Sheets("Data") 'اسم صفحة قاعدة البيانات
    ar1 = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 16) ' ترتيب اعمدة صفحة الادخال
    ar2 = Array(2, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 16) 'ترتيب اعمدة قاعدة البيانات بما يقابلها من صفحة ادخال البيانات
    arr = Add.Range(Add.Cells(ro1, co1), Cells(Add.Cells(Rows.Count, co1).End(xlUp).Row, co1 + co_num1)).Value
    If Add.Cells(ro1, co1) = "" Then MsgBox "يرجى ادخال البيانات ثم الترحيل": Exit Sub
    v = Data.Cells(Rows.Count, co2).End(xlUp).Row
        For xx = LBound(ar2) To UBound(ar2)
        ReDim y(1 To UBound(arr, 1))
            For x = LBound(arr) To UBound(arr)
            If ar2(xx) <> "" Then
               rw = rw + 1
                y(rw) = arr(x, ar1(xx))
            End If
        Next
    If rw > 0 Then Data.Cells(v, co2 + (ar2(xx) - 1))(2, 1).Resize(UBound(y, 1)).Value = Application.Transpose(y)
        Erase y
        rw = 0
    Next
    Erase arr
    Add.Range(Add.Cells(ro1, co1), Cells(Add.Cells(Rows.Count, co1).End(xlUp).Row, co1 + co_num1)).ClearContents
    MsgBox "Done............"
End Sub


اترك لكم التجربة لان الوقت لا يسمح لعدة محاولات اذاصادفتكم اي مشاكل يرجى ارفاقها في مشاركة اسفل الموضوع
الملف مرفق
attachترحيل مرن 1.zip
اعداد / ياسر العربي
142
 
 
  ترحيل مرن 1.zip   تحميل zip مرات التحميل :(325)
الحجم :(22.407) KB


أثارت هذه المشاركة إعجاب: abouelhassan، السعيد الجزائري، تاج الدين،


توقيع :Yasser Elaraby
663013020

look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 12:46 صباحاً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 14
المشاركات : 1309
الدولة : مصر
الجنس :
تاريخ الميلاد : 4-7-1990
الدعوات : 59
قوة السمعة : 4570
الاعجاب : 0
موقعي : زيارة موقعي
بارك الله فيك استاذ ياسر العربي رائع رائع رائع
ولى رجاء اذا كان احدهم يريد ان يضع شرط في الترحيل هل يمكن تعديل هذا الكود ليقبل شروط
ام هو لترحيل اعمدة غير متجاورة فقط

واكرر شكرى لحضرتك على هذا العمل الرائع
وبارك الله فيك



توقيع :محمود ابو الدهب
لى عظيم الشرف بالانضمام لهذا الصرح العظيم
وكم أتمنى من الله
ان يعيننى ويعلمنى من علمة الواسع فهو ولي ذالك وهو على كل شي قدير

تحياتى وتقدير للجميع  محمود ابوالدهب

look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 12:59 صباحاً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 1
المشاركات : 1332
الجنس :
الدعوات : 13
قوة السمعة : 10066
الاعجاب : 67
موقعي : زيارة موقعي
الشروط اشكال والوان حدد الشروط اللي محتاجها على ملف وارفقه وان شاء الله اعدل الملف ليناسب الشروط
بس حاليا يادوب بقي الواحد يناااااااام تصبح على خيرر blink



توقيع :Yasser Elaraby
663013020

look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 01:05 صباحاً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 14
المشاركات : 1309
الدولة : مصر
الجنس :
تاريخ الميلاد : 4-7-1990
الدعوات : 59
قوة السمعة : 4570
الاعجاب : 0
موقعي : زيارة موقعي
كنت اقصد ان يكون الشرط متغير بمعنى يكفينى ان احدد رقم العمود الذى به الشرط ثم احدد هلى يحتوى هذا العمود على كذا او كبر من كذا او اصغر او يساوى
اى اقصد ان يكون مثل الكود سهل للمستخدم العادى او للى مش بيعرف يتعامل مع الاكواد يسهل التعامل معه


وانا كمان يدوبك دلوقتى انام احلام سعيده ليك وليا ومتنشاس اتغطي كويس بدل ما الاحلام تقلب كوابيس biggrin2 واحنا في الشتاء

تحياتى وتقديرى لك 113


تم تحرير المشاركة بواسطة :محمود ابو الدهب بتاريخ:15-12-2017 01:06 صباحاً




توقيع :محمود ابو الدهب
لى عظيم الشرف بالانضمام لهذا الصرح العظيم
وكم أتمنى من الله
ان يعيننى ويعلمنى من علمة الواسع فهو ولي ذالك وهو على كل شي قدير

تحياتى وتقدير للجميع  محمود ابوالدهب

look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 04:55 صباحاً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 30-09-2017
رقم العضوية : 779
المشاركات : 7
الجنس :
قوة السمعة : 14
الاعجاب : 0
المحترم بزياده كنت بسأل على الترحيل من الفورم حسب كود الصنف




look/images/icons/wub.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 12:57 مساءً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس :
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
الاعجاب : 0
المحترم ياسر العربي
كا فأك الله بكل خير
وبعد :
هذا هو الملف الذي نريد ان نتشرف باضافة كودك الرائع اليه
والشرطين موجودين في صفحه الهدف

attachترحيل مرن 2.rar
 
 
  ترحيل مرن 2.rar   تحميل rar مرات التحميل :(50)
الحجم :(300.512) KB





look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 05:44 مساءً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-11-2017
رقم العضوية : 1941
المشاركات : 1
الجنس :
قوة السمعة : 14
الاعجاب : 0
عمل جميل ومفيد جداً .... شكراً جزيلاً لك




look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 08:10 مساءً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 1
المشاركات : 1332
الجنس :
الدعوات : 13
قوة السمعة : 10066
الاعجاب : 67
موقعي : زيارة موقعي
المشاركة الأصلية كتبت بواسطة: ناصر سعيد1 المحترم ياسر العربي
كا فأك الله بكل خير
وبعد :
هذا هو الملف الذي نريد ان نتشرف باضافة كودك الرائع اليه
والشرطين موجودين في صفحه الهدف

attachترحيل مرن 2.rar
تفضل اخي الكريم ناصر وعدل باقي الاعمدة بما يقابلها كما موضح بالمرفق في اول اعمدة
طبعا الملف تم انشائه لترحيل البيانات ولكن الان قمنا بتدويره للاستدعاء

attachترحيل مرن 2.zip



توقيع :Yasser Elaraby
663013020

look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 08:51 مساءً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس :
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
الاعجاب : 0
استاذ ياسر العربي
يحفظك الرحمن
وبعد :
المسلسل خليه يظهر مع الكود
وكذلك التسطير بعدد المستدعى
جزاك الله كل خير




look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 08:53 مساءً   [9]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس :
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
الاعجاب : 0
من فضلك شويه شرح للاسطر عشان حبايبك




look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 09:32 مساءً   [10]
معلومات الكاتب ▼
تاريخ الإنضمام : 27-08-2017
رقم العضوية : 247
المشاركات : 202
الجنس :
تاريخ الميلاد : 13-4-1966
قوة السمعة : 613
الاعجاب : 0
أستاذنا الفاضل زادك الله علما وبركة وجزاك الله عنا خير الجزاء




look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  15-12-2017 09:56 مساءً   [11]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس :
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
الاعجاب : 0
المشاركة الأصلية كتبت بواسطة: محمد أبو عبدو أستاذنا الفاضل زادك الله علما وبركة وجزاك الله عنا خير الجزاء
حقا الاستاذ ياسر يستحق الدعاء .. عندما يشرب كوبا من البن المحوج بيطلع ابداعات
ربنا يحفظه




look/images/icons/i1.gif ترحيل مرن وسريع وسهل ضبطه
  16-12-2017 12:31 صباحاً   [12]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-09-2017
رقم العضوية : 705
المشاركات : 440
الجنس :
تاريخ الميلاد : 2-2-1990
قوة السمعة : 657
الاعجاب : 0
بفضل من الله
تم عمل الاسطر البرمجيه الخاصه بالتسطير
اولا : هل موقعها تمام في الكود ؟

ثانيا لم استطع وضع سطربرمجي لعمل المسلسل فارجو اضافته
جزاكم الله خيرا
CODE

Sub Yasser()
'هذا الكود للمحترم ياسر العربي
'الهدف من الكود هو استدعاء بيانات
'بشرطين من خارج الكود
'تم هذا الكود بتاريخ 15/12/2017
'========
    Dim Main As Worksheet
    Dim Sh As Worksheet
    Dim j       As Long
    Dim ar1 As Variant
    Dim ar2 As Variant
    Dim arr As Variant
    Dim v As Long, rw, x, xx
    Const co1 As Long = 2 'رقم اول عمود لصفحة المصدر
    Const co2 As Long = 3  'رقم اول عمود لصفحة الهدف
    Const ro1 As Long = 7 'رقم اول صف لصفحة المصدر
    Const co_num1 As Long = 150 ' عدد الاعمدة المراد الترحيل منها
    Set Main = Sheets("رصد الترم الثانى") 'اسم صفحة المصدر
    Set Sh = Sheets("الهدف") 'اسم صفحة الهدف
    
    ar1 = Array(1, 2, 139, 143, 141, 142, 7, 8, 9, 10, 11, 13, 15, 132) ' ترتيب اعمدة صفحة المصدر
    
    ar2 = Array(1, 2, 3, 4, 5, 6, 8, 7, 9, 10, 11, 13, 15, 35) 'ترتيب اعمدة قاعدة البيانات بما يقابلها من صفحة  الهدف
    
    'لمنع اهتزاز الشاشه
    Application.ScreenUpdating = 0
    Sh.Range(Sh.Cells(ro1, co2), Sh.Cells(Sh.Cells(Rows.Count, co2).End(xlUp).Row + 1, co2 + co_num1)).ClearContents
 
    arr = Main.Range(Main.Cells(ro1, co1), Main.Cells(Main.Cells(Rows.Count, co1).End(xlUp).Row, co1 + co_num1)).Value
    If Main.Cells(ro1, co1) = "" Then MsgBox "يرجى ادخال البيانات ثم الترحيل": Exit Sub
    v = Sh.Cells(Rows.Count, co2).End(xlUp).Row
        For xx = LBound(ar2) To UBound(ar2)
        
        ReDim y(1 To UBound(arr, 1))
            For x = LBound(arr) To UBound(arr)
            j = 1
            If ar2(xx) <> "" Then
            If arr(x, 132) Like Sh.Range("D1") & "*" And arr(x, 143) Like Sh.Range("E1") Then
               rw = rw + 1
                y(rw) = arr(x, ar1(xx))
                End If
            End If
        Next
    If rw > 0 Then Sh.Cells(v, co2 + (ar2(xx) - 1))(2, 1).Resize(UBound(y, 1)).Value = Application.Transpose(y)
        Erase y
        rw = 0
    Next
    Erase arr
   '========
  'سطر لمسح التسطير
  Sh.Range("B7:AM" & Rows.Count).Borders.Value = 0
 
        'سطر لاضافة التسطير
   Sh.Range("B7:AM" & Cells(Rows.Count, 3).End(xlUp).Row).Borders _
       .Weight = xlMedium
   '=======
   'لاعاده الشاشه
      Application.ScreenUpdating = 1
    MsgBox "الحمد لله تم المطلوب"
End Sub




اضافة رد جديد اضافة موضوع جديد
الصفحة 2 من 7 < 1 2 3 4 7 > الأخيرة




المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
ترحيل البيانات اتوماتيكيا الى عدد محدود من اوراق العمل بطريقة سهله وسريعه حسين الحمادي
1 1334 حسين الحمادي
اكسل vbaجصريا فورم بحث وتعديل البيانات فى جميع اوراق العمل(شيتات الاكسل ) بطريقة سهلة وسريعة emad ghazi
27 8197 Hatem Eissa
اكسل vba ترحيل البيانات اتوماتيكيا الى عدد غير محدود من اوراق العمل بطريقة سهله وسريعه emad ghazi
26 12802 مدحت حافظ
اريد طريقة سهله وسريعة للترقيم المتسلسل في الاكسل عمودي وافقي في نفس الوقت ابو يوسف80
14 2739 Eslam Abdullah
اكسل vba حذف اوراق العمل الفارغة بطريقة سهلة وسريعة emad ghazi
5 3659 emad ghazi

الكلمات الدلالية
ترحيل ، وسريع ، وسهل ، ضبطه ،









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

الساعة الآن 11:20 PM