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

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


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



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





ترحيل بيانات

السلام عليكم إخوتي : عندي في الملف المرفق أريد ترحيل البيانات (الاسم و اللقب ndash; القسم ) من شيت data إلى شيت data2 ب ..



04-12-2018 07:03 مساء
ayoub2007
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 63
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 30
الاعجاب : 2
 offline 

السلام عليكم إخوتي :
عندي في الملف المرفق
  1. أريد ترحيل البيانات (الاسم و اللقب – القسم ) من شيت data إلى شيت data2 بحيث كل قسم يأخذ 50صف يعني القسم س1 (50صف حتى لو كان عدد الطلبة أقل من كذا) و يجي  وراه القسم س2 بنفس المواصفات ..............الخ بحيث لو أضفت طالب في data   في أخر صف  يطلع في القسم بتاعه في data2
  2. اريد حساب تعداد الطلبة حسب الصفة و الجنس كما هو مبين في الجدول مع اخذ الاعتبار إذا أضفت قسم مثلا س11 يرتبه في اخر الصف في خانة القسم و يحسب تعداده
و شكرا مسبقا
 
 
 
  الطلبة.rar   تحميل rar مرات التحميل :(2)
الحجم :(16.53) KB







04-12-2018 08:55 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 330
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 13
قوة السمعة : 2897
الاعجاب : 72
 offline 
look/images/icons/i1.gif ترحيل بيانات
جرب هذا الماكرو

Option Explicit
Sub give_data()
If ActiveSheet.Name <> "data" Then Exit Sub
Dim i%: i = 3
Dim Laste_Row%, k%, m%
Dim arr, arr_num()
Dim rg As Object
arr_num = Array(3, 52, 101, 150, 199, 248, 297, 346, 395, 444)
Laste_Row = Sheets("data").Cells(Rows.Count, 1).End(3).Row
Sheets("data2").Range("a3").Resize(1000, 3).ClearContents

Set rg = CreateObject("system.collections.arraylist")
With rg
 Do Until i > Laste_Row
  If Not .contains(UCase(Range("g" & i).Value)) Then .Add UCase(Range("g" & i).Value)
 i = i + 1
 Loop

  arr = .toarray
 End With
 For i = LBound(arr) To UBound(arr)
   m = arr_num(i)
    For k = 3 To Laste_Row%
      If Sheets("data").Cells(k, "G") = arr(i) Then
         With Sheets("data2").Cells(m, 1)
           .Value = Sheets("data").Cells(k, "A")
           .Offset(, 1) = Sheets("data").Cells(k, "B")
           .Offset(, 2) = Sheets("data").Cells(k, "G")
            m = m + 1
         End With
       End If
     Next
  Next
  Set rg = Nothing: Erase arr_num: Erase arr
End Sub

الملف مرفق

لا افهم ما هذا الشيء الذي يظهر مع كل اضافة كود الى المنتدى
NDU5NzE26Capturesal
 
 
  std_salim.rar   تحميل rar مرات التحميل :(7)
الحجم :(30.776) KB



تم تحرير المشاركة بواسطة :salim
بتاريخ:04-12-2018 08:59 مساء






04-12-2018 09:10 مساء
مشاهدة مشاركة منفردة [2]
ayoub2007
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 63
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 30
الاعجاب : 2
 offline 
look/images/icons/i1.gif ترحيل بيانات
الف شكر استاذ سليم. وان أمكن طريقة لحساب التعداد و  شكرا





04-12-2018 09:37 مساء
مشاهدة مشاركة منفردة [3]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 330
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 13
قوة السمعة : 2897
الاعجاب : 72
 offline 
look/images/icons/i1.gif ترحيل بيانات
تعديل الماكرو بحيبث يظهر الترقيم

Option Explicit
Sub give_data()
If ActiveSheet.Name <> "data" Then Exit Sub
Dim s%
Dim i%: i = 3
Dim Laste_Row%, k%, m%
Dim arr, arr_num()
Dim rg As Object
arr_num = Array(3, 52, 101, 150, 199, 248, 297, 346, 395, 444)
Laste_Row = Sheets("data").Cells(Rows.Count, 1).End(3).Row
Sheets("data2").Range("a3").Resize(1000, 3).ClearContents

Set rg = CreateObject("system.collections.arraylist")
With rg
 Do Until i > Laste_Row
  If Not .contains(UCase(Range("g" & i).Value)) Then .Add UCase(Range("g" & i).Value)
 i = i + 1
 Loop

  arr = .toarray
 End With
 For i = LBound(arr) To UBound(arr)
   m = arr_num(i)
   s = 1
    For k = 3 To Laste_Row%
      If Sheets("data").Cells(k, "G") = arr(i) Then
         With Sheets("data2").Cells(m, 1)
           .Value = s: s = s + 1
           .Offset(, 1) = Sheets("data").Cells(k, "B")
           .Offset(, 2) = Sheets("data").Cells(k, "G")
            m = m + 1
         End With
       End If
     Next
  Next
  Set rg = Nothing: Erase arr_num: Erase arr
End Sub


الملف من جديد
 
 
 
  std_salim1.rar   تحميل rar مرات التحميل :(14)
الحجم :(30.81) KB


أثارت هذه المشاركة إعجاب: مدحت حافظ،




05-12-2018 01:20 صباحا
مشاهدة مشاركة منفردة [4]
عبدالله فتحى
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-07-2018
رقم العضوية : 7066
المشاركات : 58
الجنس : ذكر
تاريخ الميلاد : 28-11-1982
يتابعهم : 14
يتابعونه : 2
قوة السمعة : 110
الاعجاب : 1
 offline 
look/images/icons/i1.gif ترحيل بيانات
جزاك الله خيرا اخى الكريم 
وزادك الله من العلم والرزق 





05-12-2018 06:20 صباحا
مشاهدة مشاركة منفردة [5]
مالك ماريه
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 15-12-2017
رقم العضوية : 2523
المشاركات : 517
الجنس : ذكر
تاريخ الميلاد : 13-3-1990
يتابعهم : 3
يتابعونه : 6
قوة السمعة : 761
الاعجاب : 54
 offline 
look/images/icons/i1.gif ترحيل بيانات
كما عودتنا والله يا ستاذ سليم مبدع دائما جزاكم الله خير وجعله الله فى ميزان حسناتك






المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
تعديل كود الترحيل المبتدأ
14 104 YasserKhalil
ترحيل من شيت غلى أخرى بشروط morestudy
15 260 morestudy
ترحيل الاشكال من ورقة عمل الى اخرى المبتدأ
10 78 YasserKhalil
ترحيل الى شيت اخر sobhy30003
32 282 YasserKhalil
ترحيل من تكست بوكس الى ليست بوكس الى شيت معين Yasser Elaraby
16 1735 salim5d

الكلمات الدلالية
ترحيل ، بيانات ،


 







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



الساعة الآن 07:31 صباحا

أعلن هنا
أعلن هنا
أعلن هنا