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

سيد الأكرت · مايو 9, 2017

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

**ابراهيم الحداد** · مايو 9, 2017

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

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

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

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

سيد الأكرت · مايو 9, 2017

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

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

**سليم حاصبيا** · مايو 9, 2017

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

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

سيد الأكرت · مايو 9, 2017

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

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

**ابراهيم الحداد** · مايو 9, 2017

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

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

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

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

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

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

سجل.rar

سيد الأكرت · مايو 9, 2017

52 دقائق مضت, زيزو العجوز said:

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

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

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

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

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

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

سجل.rar

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

**ابراهيم الحداد** · مايو 9, 2017

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

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

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

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

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

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

**سليم حاصبيا** · مايو 10, 2017

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

سيد الأكرت · مايو 10, 2017

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

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

سيد الأكرت · مايو 10, 2017

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

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

**ابو عبدالبارى** · مايو 10, 2017

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

السلام عليكم

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

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

سيد الأكرت · مايو 10, 2017

2 ساعات مضت, ابو عبدالبارى said:
الأخ الفاضلسيد تيجر

السلام عليكم

قم باستخدام المعادلة التالية
=SUMPRODUCT(('السجل الكلي'!$F$9:$F$3008="ذكر")*('السجل الكلي'!$E$9:$E$3008=6))

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

**محمد الورفلي1** · مايو 10, 2017

السلام عليكم

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

سجل.rar

سيد الأكرت · مايو 11, 2017

16 ساعات مضت, محمد الخازمي said:

السلام عليكم

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

سجل.rar

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

تسجيل الدخول

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

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

سيد الأكرت

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

سيد الأكرت

سليم حاصبيا

سيد الأكرت

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

سيد الأكرت

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

سليم حاصبيا

سيد الأكرت

سيد الأكرت

ابو عبدالبارى

سيد الأكرت

محمد الورفلي1

سيد الأكرت

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information