محتاج كود ترحيل مادة

[2saad]

إخواني أعضاء المنتدي الكرام بعد سلام الله عليكم ورحمته وبركاته
أتقدم بخالص الشكر لكل الاعضاء لاني تعلمت منهم الكثير في هذا المنتدي الجليل
بالضغط علي زر الكود يقوم بترحيل البيانات من sheet1  و sheet2  و sheet3 الي شيت ( saad ) بناء علي القائمة المنسدلة r12    
المطلوب عند الضغط علي القائمة المنسدلة U12  واختيار المادة يتم ترحيل الدرجات الخاصة بها علي حسب الفصل
ولكم جزيل الشكرترحيل الدرجات.xlsm

[محمد هشام.]

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

Public Sub CopyData()
Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant
Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range
Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long

Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad")

Col_Star = 10: Col_Search = 18: Clé1 = desWS.[R12]: Clé2 = desWS.[U12]

With Application
        .EnableEvents = False
        .ScreenUpdating = False
        
If Len(Clé1) > 0 And Len(Clé2) > 0 Then
 desWS.Range("C14:U" & Rows.Count).ClearContents

        Sh = Array("Sheet1", "Sheet2", "Sheet3")
        For i = LBound(Sh) To UBound(Sh)
            Set WSData = Sheets(Sh(i))
           
 With WSData
    .AutoFilterMode = False
    Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row
    ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rngFound = .Range("C9:T" & ligne)
End With

For Rng = Col_Star To Irow
 If WSData.Cells(Rng, Col_Search).Value = Clé1 Then
    rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row
 Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20)
 
For c = 0 To UBound(Cpt)
desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSData.Cells(Rng, Cpt(c)).Value
            Next c
        End If
    Next Rng
    
  rngFound.AutoFilter Field:=16, Criteria1:=Clé1
  Set rngSearch = WSData.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole)
     If Not rngSearch Is Nothing Then
     rngSearch.Offset(1).Resize(ligne - 1).Copy
       desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues
         rngFound.AutoFilter: desWS.[R12].Select
       
           End If
         Next i
       End If
   .EnableEvents = True
 .ScreenUpdating = True
End With
End Sub

 

ترحيل الدرجات v2.xlsm

[2saad]

شكرا جزيلا استاذ محمد وبارك الله فيك

بعد إذن حضرتك يا استاذ محمد ممكن شرح للكود لكي اطبقه في اشياء اخري

وشكر لتعبك معنا

[محمد هشام.]

8 ساعات مضت, 2saad said:

ممكن شرح للكود لكي اطبقه في اشياء اخري

وشكر لتعبك معنا

Public Sub CopyData2()
Dim Irow&, Rng&, rowLast&, c&, Cpt As Variant
Dim Clé1 As String, Clé2 As String, rngFound As Range, rngSearch As Range
Dim Col_Star As Long, Col_Search As Long, i As Long, lRow As Long
Dim desWS As Worksheet: Set desWS = ThisWorkbook.Worksheets("saad")
' خلية البداية
Col_Star = 10

'(R) عمود الشرط
Col_Search = 18

'الشرط الاول(الفصل)
Clé1 = desWS.[R12]

'الشرط الثاني (المادة)
Clé2 = desWS.[U12]

With Application
        .EnableEvents = False
        .ScreenUpdating = False
 'التحقق من وجود قيمة في خلايا الشرط
If Len(Clé1) > 0 And Len(Clé2) > 0 Then
' افراغ البيانات السابقة
 desWS.Range("C14:U" & Rows.Count).ClearContents
' اسماء الاوراق المستهدفة
        Sh = Array("Sheet1", "Sheet2", "Sheet3")
        For i = LBound(Sh) To UBound(Sh)
            Set WSdata = Sheets(Sh(i))
           
 With WSdata
' الغاء الفلترة
    .AutoFilterMode = False
'
    Irow = .Cells(.Rows.Count, Col_Search).End(xlUp).Row
    ligne = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' النطاق
    Set rngFound = .Range("C9:T" & ligne)
End With

For Rng = Col_Star To Irow
' في حالة تحقق الشرط الاول
 If WSdata.Cells(Rng, Col_Search).Value = Clé1 Then
'عمود (C) تحديد اخر صف عليه بيانات
    rowLast = desWS.Cells(desWS.Rows.Count, 3).End(xlUp).Row
' الاعمدة المرغوب جلب بياناتها
 Cpt = Array(3, 4, 5, 6, 5, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20)
For c = 0 To UBound(Cpt)
 ' لصق البيانات بعد اخر قيمة من عمود (C)
desWS.Cells(rowLast, Cpt(c)).Offset(1, 0).Value = WSdata.Cells(Rng, Cpt(c)).Value
            Next c
        End If
    Next Rng
    ' فلترة جميع الاوراق على الشرط الاول
  rngFound.AutoFilter Field:=16, Criteria1:=Clé1
' البحث في الصف 9 عن الشرط الثاني (المادة)
  Set rngSearch = WSdata.Rows(9).Find(Clé2, LookIn:=xlValues, lookat:=xlWhole)
     If Not rngSearch Is Nothing Then
'نسخ بيانات العمود
     rngSearch.Offset(1).Resize(ligne - 1).Copy
' لصق بعد اخر خلية من عمود (U)
       desWS.Cells(Rows.Count, 21).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'الغاء الفلترة
         rngFound.AutoFilter: desWS.[R12].Select
       
           End If
         Next i
       End If
   .EnableEvents = True
 .ScreenUpdating = True
End With
End Sub

 

تم تعديل يناير 27 بواسطه محمد هشام.
شرح الكود

[2saad]

بارك الله فيك وأكثر الله من أمثالك وربنا يزيدك من علمه

[2saad]

eman.xlsmاستاذ محمد بع سلام الله عليكم ورحمة الله وبركاته

أنا حاولت اطبق الكود السابق علي ملف عندي ولم يفلح 

أنا بتعب حضرتك معي كثيرا

مرفق ملف الذي اردت التطبيق عليه

[محمد هشام.]

53 دقائق مضت, 2saad said:

أنا حاولت اطبق الكود السابق علي ملف عندي ولم يفلح

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

1) عدم تطابق الاسماء في رؤوس اعمدة المواد والقائمة المنسدلة 

2) لم تقم بتغيير عمود لصق البيانات ليتوافق مع الشكل الجديد 

' لصق بعد اخر خلية من عمود (AG)
       desWS.Cells(Rows.Count, 33).End(xlUp).Offset(1).PasteSpecial xlPasteValues

Or
 desWS.Cells(desWS.Rows.Count, "AG").End(xlUp).Offset(1).PasteSpecial xlPasteValues

مع تفريغه في اول الكود بالشكل التالي لكي لا يتم نسخ البيانات تحت بعضها البعض 

 desWS.Range("AG13:AG" & Rows.Count).ClearContents

وفي حدث ورقة saad

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Select Case Target.Address(0, 0)
    Case "Y7": Call CopyData2: Case "AF8": Call CopyData2
    Target.Select
    Case Else: Exit Sub  
End Select
End Sub

 

eman v2.xlsm

تم تعديل يناير 29 بواسطه محمد هشام.

[2saad]

شكرا جزيلا أستاذنا الفاضل