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

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


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





ترحيل بيانات

السلام علكيم أريد ترحيل بينات من شيت data إلى شيت Liste لجلب القائمة الاسمية للتلاميذ حسب القسم الموجود في الالقائمة الم ..


موضوع مغلق


subject icon تمت الإجابة ترحيل بيانات
23-08-2020 04:20 مساء
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 160
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 

السلام علكيم


أريد ترحيل بينات من شيت data إلى شيت Liste لجلب القائمة الاسمية للتلاميذ حسب القسم الموجود في الالقائمة المنسدلة بالخلية G7

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


 
 
  my book.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(582.541) KB



أفضل إجابة مقدمة من salim وهي:

جرب هذا الملف



في حال تريد كل الطلاب من نفس الصف (ذكر + أنثى)  اترك الخلية H2  فارغة واضغط الزر Run



Option Explicit
Sub Avd_filter()
Dim d As Worksheet, L As Worksheet
Dim RgL As Range, Cret_range As Range
Dim Where As Range
Set d = Sheets("data"): Set L = Sheets("Liste")
Set RgL = d.Range("a1").CurrentRegion
Set Where = L.Range("a10:F10")
L.Range("H1") = d.Range("E1")
L.Range("I1") = d.Range("H1")
L.Range("I2") = L.Range("G7")
Set Cret_range = L.Range("H1:i2")
RgL.AdvancedFilter 2, Cret_range, Where
L.Range("H1") = vbNullString
L.Range("I1:i2") = vbNullString
End Sub

الملف مرفق

عرض الإجابة




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

23-08-2020 05:08 مساء
مشاهدة مشاركة منفردة [2]
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 160
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 
look/images/icons/i1.gif ترحيل بيانات
في الحقيقة الأستاذ ياسر أنا نقلت الكود من إحدى الموضوعات بالمنتدى أظن للأستاذ سليم و غيرت بعض المعطيات و لكن لم أعرف أين الخلل بالصبط

Sub edit_eleves()
Application.ScreenUpdating = False
'If ActiveSheet.Name <> "Liste" Then GoTo Thank_you
Dim data_sh As Worksheet: Set ALL_sh = Sheets("data")
Dim Liste_sh As Worksheet: Set Single_sh = Sheets("Liste")
Dim Target_sh As Worksheet: Set Target_sh = Sheets("Liste")
Dim New_row%, arr(), i%, k%: k = 1
Target_sh.Range("a1:X500").Clear
Dim My_Tabl As Range, Print_Rg As Range
Dim My_st$: My_st = Liste_sh.Range("G7")
Dim last_row%: last_row = data_sh.Cells(5, 1).CurrentRegion.Rows.Count + 4
Liste_sh.Range("a11:g100").ClearContents
 Set My_Tabl = data_sh.Range("a12:x" & last_row)
 Target_sh.Range("z1") = data_sh.Range("h1")
 Target_sh.Range("z2") = My_st
 My_Tabl.AdvancedFilter 2, Target_sh.Range("z1:z2"), Target_sh.Range("a11")
 New_row = Target_sh.Cells(Rows.Count, 1).End(3).Row
  ReDim arr(1 To 5)
   arr(1) = 1: arr(2) = 2: arr(3) = 3
   arr(4) = 4: arr(5) = 9
   For i = 1 To 5
    Liste_sh.Cells(11, k).Resize(New_row - 4, 1).Value = _
    Target_sh.Cells(5, arr(i)).Resize(New_row - 4, 1).Value
    k = k + 1
   Next
   Liste_sh.Cells(11, 6).Resize(New_row - 4, 1).Value = Target_sh.Range("Ad5").Value
   Liste_sh.Cells(New_row + 8, "e") = " المدير "
   Liste_sh.Cells(New_row + 8, "f") = Format(Date, "d/m/yyyy")
   Set Print_Rg = Range("a1:g" & New_row + 10)
  Single_sh.PageSetup.PrintArea = Print_Rg.Address
  Erase arr
   Application.ScreenUpdating = True
End Sub

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

جرب هذا الملف



في حال تريد كل الطلاب من نفس الصف (ذكر + أنثى)  اترك الخلية H2  فارغة واضغط الزر Run



Option Explicit
Sub Avd_filter()
Dim d As Worksheet, L As Worksheet
Dim RgL As Range, Cret_range As Range
Dim Where As Range
Set d = Sheets("data"): Set L = Sheets("Liste")
Set RgL = d.Range("a1").CurrentRegion
Set Where = L.Range("a10:F10")
L.Range("H1") = d.Range("E1")
L.Range("I1") = d.Range("H1")
L.Range("I2") = L.Range("G7")
Set Cret_range = L.Range("H1:i2")
RgL.AdvancedFilter 2, Cret_range, Where
L.Range("H1") = vbNullString
L.Range("I1:i2") = vbNullString
End Sub

الملف مرفق

 
 
  std_file.xlsm   تحميل xlsm مرات التحميل :(5)
الحجم :(630.424) KB


24-08-2020 12:16 صباحا
مشاهدة مشاركة منفردة [4]
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 160
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 
look/images/icons/i1.gif ترحيل بيانات
الف شكر لكل القائمين على المنتدى و تحية خاصة للاستاذ سليم الذي كثيرا ما ساعدني في اتمام البرنامج الذي اعمل عليه142

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



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


 










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

الساعة الآن 06:34 مساء