اذهب الي المحتوي
أوفيسنا

مطلوب استدعاء للفرقة من السجل الكلي للمدرسة

سيد الأكرت

بواسطه سيد الأكرت
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

ابراهيم الحداد

ابراهيم الحداد

قام بنشر
قام بنشر

السلام عليكم ورحمة الله

انسخ هذا الكود والصقه بموديول جديد

واربطه بالزر الموجود بالملف 

Sub CallingData()
Dim data As Worksheet, ws As Worksheet
Dim Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long
Set data = Sheets("السجل الكلي")
Set ws = Sheets("السجل المطلوب")
ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row).ClearContents
Arr = data.Range("D9:R" & data.Range("D" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 2) = ws.Range("Q2") Then
p = p + 1
For j = 1 To 14
Temp(p, j) = Arr(i, Choose(j, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15))
Next
End If
Next
If p > 0 Then ws.Range("D9").Resize(p, UBound(Temp, 2)).Value = Temp
If p > 0 Then ws.Range("C9") = 1: ws.Range("C9").Resize(p).DataSeries Step:=1
End Sub

 

رابط هذا التعليق
شارك
سيد الأكرت

سيد الأكرت

قام بنشر
  • الكاتب
قام بنشر
58 دقائق مضت, زيزو العجوز said:

السلام عليكم ورحمة الله

انسخ هذا الكود والصقه بموديول جديد

واربطه بالزر الموجود بالملف 


Sub CallingData()
Dim data As Worksheet, ws As Worksheet
Dim Arr As Variant, Temp As Variant
Dim i As Long, j As Long, p As Long
Set data = Sheets("السجل الكلي")
Set ws = Sheets("السجل المطلوب")
ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row).ClearContents
Arr = data.Range("D9:R" & data.Range("D" & Rows.Count).End(xlUp).Row).Value
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, 2) = ws.Range("Q2") Then
p = p + 1
For j = 1 To 14
Temp(p, j) = Arr(i, Choose(j, 1, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15))
Next
End If
Next
If p > 0 Then ws.Range("D9").Resize(p, UBound(Temp, 2)).Value = Temp
If p > 0 Then ws.Range("C9") = 1: ws.Range("C9").Resize(p).DataSeries Step:=1
End Sub

 

تسلم يا استاذ زيزو تم المطلوب والحمد لله لكن عند الاستدعاء يختفي الكلام الموجود في رؤس الاعمدة مثل م اسم التلميذ الي اخره هل يمكن تجنب اخفائها بدلا من كتابتها كل مرة وشكرا جزيلا لحضرتك

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

بعد اذن اخي زيزو و زيادة في اثراء الموضوع هذا الكود 

Option Explicit
Sub Extract_Data()
Dim Source_Sh As Worksheet
Dim Target_Sh As Worksheet
Dim lr1, lr2 As Long
Dim R, R1, x As Long
Dim My_Rg, Found_rg As Range
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 Set Source_Sh = Sheets("السجل الكلي"): Set Target_Sh = Sheets("السجل المطلوب")
 Target_Sh.Range("d9:q10000").ClearContents
 lr1 = Application.Max(Source_Sh.Range("c:c")) + 8
  Set My_Rg = Source_Sh.Range("e8:e" & lr1)
  Set Found_rg = My_Rg.Find(What:=Target_Sh.Range("q2"), lookat:=xlWhole)
  
    If Not Found_rg Is Nothing Then: R = Found_rg.Row
 
    Target_Sh.Cells(x + 9, 4).Resize(, 15).Value = Source_Sh.Cells(R, 4).Resize(, 15).Value
   Do
       x = x + 1
       Set Found_rg = My_Rg.FindNext(Found_rg): R1 = Found_rg.Row
       Target_Sh.Cells(x + 9, 4).Resize(, 15).Value = Source_Sh.Cells(R1, 4).Resize(, 15).Value
        If R1 = R Then Exit Do
  Loop
  Target_Sh.Cells(x + 9, 1).EntireRow.Delete
   Target_Sh.Cells(9, 4).Select
  With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

رابط هذا التعليق
شارك
سيد الأكرت

سيد الأكرت

قام بنشر
  • الكاتب
قام بنشر
11 دقائق مضت, سليم حاصبيا said:

بعد اذن اخي زيزو و زيادة في اثراء الموضوع هذا الكود 


Option Explicit
Sub Extract_Data()
Dim Source_Sh As Worksheet
Dim Target_Sh As Worksheet
Dim lr1, lr2 As Long
Dim R, R1, x As Long
Dim My_Rg, Found_rg As Range
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 Set Source_Sh = Sheets("السجل الكلي"): Set Target_Sh = Sheets("السجل المطلوب")
 Target_Sh.Range("d9:q10000").ClearContents
 lr1 = Application.Max(Source_Sh.Range("c:c")) + 8
  Set My_Rg = Source_Sh.Range("e8:e" & lr1)
  Set Found_rg = My_Rg.Find(What:=Target_Sh.Range("q2"), lookat:=xlWhole)
  
    If Not Found_rg Is Nothing Then: R = Found_rg.Row
 
    Target_Sh.Cells(x + 9, 4).Resize(, 15).Value = Source_Sh.Cells(R, 4).Resize(, 15).Value
   Do
       x = x + 1
       Set Found_rg = My_Rg.FindNext(Found_rg): R1 = Found_rg.Row
       Target_Sh.Cells(x + 9, 4).Resize(, 15).Value = Source_Sh.Cells(R1, 4).Resize(, 15).Value
        If R1 = R Then Exit Do
  Loop
  Target_Sh.Cells(x + 9, 1).EntireRow.Delete
   Target_Sh.Cells(9, 4).Select
  With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

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

رابط هذا التعليق
شارك
ابراهيم الحداد

ابراهيم الحداد

قام بنشر
قام بنشر

السلام عليكم ورحمة الله

اخى الكريم الاستاذ سيد الملف يعمل عندى بدون اى كشاكل

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

اخى الكريم الاستاذ سليم الكود الذى ارفقته بحلك هو كود رائع بلا شك

ولكن تم استخدام الدالة "" لان الاعمدة المطلوب ترحيلها مختلفة عن عدد اعمدة المصفوفة الام

اخى الكريم سيد اليك الملف

 

سجل.rar

  • Like 1
رابط هذا التعليق
شارك
سيد الأكرت

سيد الأكرت

قام بنشر
  • الكاتب
قام بنشر
52 دقائق مضت, زيزو العجوز said:

السلام عليكم ورحمة الله

اخى الكريم الاستاذ سيد الملف يعمل عندى بدون اى كشاكل

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

اخى الكريم الاستاذ سليم الكود الذى ارفقته بحلك هو كود رائع بلا شك

ولكن تم استخدام الدالة "" لان الاعمدة المطلوب ترحيلها مختلفة عن عدد اعمدة المصفوفة الام

اخى الكريم سيد اليك الملف

 

سجل.rar

بارك الله فيك اخى الكريم جرب حضرتك ان تضع في الخلية q2 عدد غير موجود وليكن 9 ثم اضغط جلب البيانات مرة لن تظهر بيانات واذا تم الضغط مرة اخرى عليها تحذف الكلمات الموجود في راس كل عمود واذا تم الضغط للمرة الثالثة تحذف كلمة الفرقة والرقم المحدد تحتها ولكن دون ذلك فالملف رائع بمعنى الكلمة وجزاك الله خيرا

رابط هذا التعليق
شارك
ابراهيم الحداد

ابراهيم الحداد

قام بنشر
قام بنشر

السلام عليكم ورحمة الله

اخى الكريم معذرة على تسرعى

استبدل تلك العبارة 

ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row ).ClearContents

بتلك العبارة 

ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row + 9).ClearContents

اعلم ان الفرق بسيط و لكنى لا اريد تشتيت تفكيرك فالفرق هو + 9

و تأكد ان هذا الامر لن يحدث ثانية باذن الله

هذا وبالله التوفيق

 

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر
7 ساعات مضت, زيزو العجوز said:

السلام عليكم ورحمة الله

اخى الكريم الاستاذ سيد الملف يعمل عندى بدون اى كشاكل

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

اخى الكريم الاستاذ سليم الكود الذى ارفقته بحلك هو كود رائع بلا شك

ولكن تم استخدام الدالة "" لان الاعمدة المطلوب ترحيلها مختلفة عن عدد اعمدة المصفوفة الام

اخى الكريم سيد اليك الملف

 

سجل.rar

عذراً اخي

زيزو لم انتبه الى هذه النقطة لذلك قمت بالتعديل على الكود كما يلي: 

Option Explicit

Sub Extract_Data2()
Dim Source_Sh As Worksheet
Dim Target_Sh As Worksheet
Dim lr1, lr2 As Long
Dim R, R1, m As Long
Dim My_Rg, Found_rg As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
 Set Source_Sh = Sheets("السجل الكلي"): Set Target_Sh = Sheets("السجل المطلوب")
 lr1 = Application.Max(Source_Sh.Range("c:c")) + 8
  Set My_Rg = Source_Sh.Range("e8:e" & lr1)
  Set Found_rg = My_Rg.Find(What:=Target_Sh.Range("q2"), lookat:=xlWhole)
      If Found_rg Is Nothing Then MsgBox "No Data to Transfere": GoTo 1
         R = Found_rg.Row
    Do
         Set Found_rg = My_Rg.FindNext(Found_rg): R1 = Found_rg.Row
              If m < R1 Then m = R1
             If R1 = R Then Exit Do
   Loop
  '==============================
 With Target_Sh
 .Range("d9:q10000").ClearContents
 .Cells(9, "d").Resize(m - R + 1).Value = Source_Sh.Cells(R, "d").Resize(m - R + 1).Value
 .Cells(9, "e").Resize(m - R + 1, 13).Value = Source_Sh.Cells(9, "f").Resize(m - R + 1, 13).Value
End With
1:
  With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

 

رابط هذا التعليق
شارك
سيد الأكرت

سيد الأكرت

قام بنشر
  • الكاتب
قام بنشر
11 ساعات مضت, زيزو العجوز said:

السلام عليكم ورحمة الله

اخى الكريم معذرة على تسرعى

استبدل تلك العبارة 


ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row ).ClearContents

بتلك العبارة 


ws.Range("C9:Q" & ws.Range("D" & Rows.Count).End(xlUp).Row + 9).ClearContents

اعلم ان الفرق بسيط و لكنى لا اريد تشتيت تفكيرك فالفرق هو + 9

و تأكد ان هذا الامر لن يحدث ثانية باذن الله

هذا وبالله التوفيق

 

شكرا اخي الكريم الان يعمل الملف بشكل سليم بارك الله فيك

6 ساعات مضت, سليم حاصبيا said:

عذراً اخي

زيزو لم انتبه الى هذه النقطة لذلك قمت بالتعديل على الكود كما يلي: 


Option Explicit

Sub Extract_Data2()
Dim Source_Sh As Worksheet
Dim Target_Sh As Worksheet
Dim lr1, lr2 As Long
Dim R, R1, m As Long
Dim My_Rg, Found_rg As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
 Set Source_Sh = Sheets("السجل الكلي"): Set Target_Sh = Sheets("السجل المطلوب")
 lr1 = Application.Max(Source_Sh.Range("c:c")) + 8
  Set My_Rg = Source_Sh.Range("e8:e" & lr1)
  Set Found_rg = My_Rg.Find(What:=Target_Sh.Range("q2"), lookat:=xlWhole)
      If Found_rg Is Nothing Then MsgBox "No Data to Transfere": GoTo 1
         R = Found_rg.Row
    Do
         Set Found_rg = My_Rg.FindNext(Found_rg): R1 = Found_rg.Row
              If m < R1 Then m = R1
             If R1 = R Then Exit Do
   Loop
  '==============================
 With Target_Sh
 .Range("d9:q10000").ClearContents
 .Cells(9, "d").Resize(m - R + 1).Value = Source_Sh.Cells(R, "d").Resize(m - R + 1).Value
 .Cells(9, "e").Resize(m - R + 1, 13).Value = Source_Sh.Cells(9, "f").Resize(m - R + 1, 13).Value
End With
1:
  With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

 

شكرا لك استاذنا الفاضل تم المطلوب بشكل سليم واصبحت البيانات مضبوطة في اماكنها بعد تعديلك للكود جزاك الله خيرا

رابط هذا التعليق
شارك
سيد الأكرت

سيد الأكرت

قام بنشر
  • الكاتب
قام بنشر

استفسار بسيط من اساتذتنا لو حبيت اعمل احصاء لعدد البنين والبنات بكل فرقة اعلم ان الدالة COUNTIF تقوم بحساب تكرار نص معين في مدى محدد ومن ثم اذا وضعت هذه المعادلة =COUNTIF('السجل الكلي'!$F$9:$F$3008;"ذكر")

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

رابط هذا التعليق
شارك
سيد الأكرت

سيد الأكرت

قام بنشر
  • الكاتب
قام بنشر
2 ساعات مضت, ابو عبدالبارى said:

الأخ الفاضلسيد تيجر

السلام عليكم

قم باستخدام المعادلة التالية 


=SUMPRODUCT(('السجل الكلي'!$F$9:$F$3008="ذكر")*('السجل الكلي'!$E$9:$E$3008=6))

 

 

ربنا يبارك في حضرتك ويجازيك بكل الخير

  • Like 1
رابط هذا التعليق
شارك
سيد الأكرت

سيد الأكرت

قام بنشر
  • الكاتب
قام بنشر
16 ساعات مضت, محمد الخازمي said:

السلام عليكم

 

اثراء للحل عن طريق الماكرو بعد ازالة الدمج

 

 

سجل.rar

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

رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept