طلب ترحيل بيانات من عدة أوراق لورقة واحدة في ملف عمل

[أبو عبدالإله]

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

 

جمعة مباركة على الجميع .

أحبتي لدي ملف عمل وأريد ترحيل بيانات أعمدة محددة من عدة ورقات في نفس الملف إلى ورقة محددة . 

 

أتمنى منكم المساعدة بعمل مايكرو يقوم بذلك ، بحيث يجلب البيانات ، وعند الضغط عليه مرة أخرى يمنع تكرار نفس البيانات .

 

ملفي.rar

تم تعديل فبراير 26, 2016 بواسطه أبو عبدالإله

[ياسر خليل أبو البراء]

أخي الكريم أبو عبد الإله

جرب الكود التالي عله يفي بالغرض

Sub TransferFromSheets()
    Dim WS As Worksheet, SH As Worksheet, LR As Long, Cell As Range, lRow As Long, I As Long
    Set SH = Sheets("خلاصة")
    lRow = 5
    
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    
        With SH.Range("B4").CurrentRegion
            .Offset(1).ClearContents: .Offset(1).Interior.Color = xlNone: .Borders.LineStyle = xlNone
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
        End With
        
        For Each WS In ThisWorkbook.Worksheets
            If WS.Name <> SH.Name And WS.Name <> "الدروس" And WS.Name <> "العلامات" And WS.Name <> "ورقة2" Then
                LR = WS.Cells(31, 3).End(xlUp).Row
                If LR < 11 Then GoTo Skipper
                
                For Each Cell In WS.Range("E11:E" & LR)
                    If Not IsEmpty(Cell) And IsDate(Cell) Then
                        SH.Cells(lRow, "C").Resize(1, 4).Value = Cell.Offset(, -2).Resize(1, 4).Value
                        lRow = lRow + 1
                    End If
                Next Cell
            End If
Skipper:
        Next WS
        
        Call RemoveDuplicateRows
        
        For I = 5 To SH.Cells(Rows.Count, "C").End(xlUp).Row
            SH.Cells(I, "B").Value = I - 4
        Next I
        
        With SH.Range("B5:F" & SH.Cells(Rows.Count, "C").End(xlUp).Row + 1)
            .EntireRow.RowHeight = 19: .ReadingOrder = xlRTL: .Font.Bold = True
            .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter
        End With
        
        With SH.Range("B" & SH.Cells(Rows.Count, "B").End(xlUp).Row + 1)
            .Resize(1, 4).HorizontalAlignment = xlCenterAcrossSelection
            .Resize(1, 4).Interior.Color = 5287936
            .Value = "مجموع المشاركين"
            .Offset(, 4).Formula = "=COUNTA(F5:F" & .Row - 1 & ")"
        End With
        
        With SH.Range("B4").CurrentRegion
            .Borders.Weight = xlThin: .BorderAround Weight:=xlThin: .Range("A1").Select
        End With
    
    Application.ScreenUpdating = False
    Application.Calculation = xlAutomatic
End Sub

Sub RemoveDuplicateRows()
    Dim Rng As Range
    
    With Sheets("خلاصة")
        Set Rng = .Range("C4:F" & .Cells(Rows.Count, "C").End(xlUp).Row)
        Rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
    End With
End Sub

تقبل تحياتي

 

[أبو عبدالإله]

أستاذنا الفاضل ياسر

 

حقيقة أفضالك وجمايلك علينا كثيرة جدا ، فأسأل الله أن يجيزيك عنا خير الجزاء وأن يوفقك ويسدد دربك .

 

حقيقة عمل أكثر من رائع يدل على تمكنك وتميزك ، زادك الله علما .

 

لي طلب بسيط :

 

وهو أن الصفوف قد تزيد في الجدول وذلك عن طريق إضافة صف ، وبيانات الصف الزائد في نهاية الجدول لا تظهر .

 

فهل يمكن أن يتم التعديل على الكود بحيث لا يتم جعله لصفوف محددة ، بل يحضر بيانات جميع الصفوف التي فوق الصف المظلل بالأسود مهما كان عددها .

 

فلو كان بالإمكان عمل ذلك إن سمح وقتكم الثمين .

 

وأعتذر إن أثقلت على حضرتكم .

 

 

أكرر شكري وتقديري لك ياغالي .

[ياسر خليل أبو البراء]

أخي الكريم أبو عبد الإله

جزيت خيراً بمثل ما دعوت لنا ..بارك الله فيك

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

 LR = WS.Cells(31, 3).End(xlUp).Row

حيث الرقم 31 هو رقم السطر المظلل بالأسود .. وهذا طلبك ..

يمكنك استبدال الرقم 31 بكلمة Rows.Count ليتم احتساب آخر صف في العمود الثالث بالكامل

إذا لم يكن هذا مقصودك فبرجاء التوضيح بالصور أو بالأمثلة أو بإرفاق شكل النتائج المتوقعة

تقبل تحياتي

[أبو عبدالإله]

أحرجتني بطيب أخلاقك

 

بعد تغيير الرقم بـ  Rows.Count

أصبح العمل كاملا ونموذجيا جدا

 

فلك كل الشكر والتقدير .

لاحرمنا الله منك ومن علمك . وجعل ذلك في ميزان حسناتك .

[ياسر خليل أبو البراء]

الحمد لله الذي بنعمته تتم الصالحات والحمد لله أن تم المطلوب على خير ..

تقبل تحياتي

[mahmoud hassan]

استاذ أبو عبد الإله واستاذنا الفاضل ياسر خليل ممكن اقطع من وقتكم 10 دقائق في استفسار بسيط بالنسبة للحضور والانصراف في الاكسيل 

[أبو عبدالإله]

حياك الله أخي محمد

سؤال للفائدة أستاذي ياسر :

 

لو كانت قيمة العمود E نص أو أي قيمة ، فماذا أغير في الكود ؟

[أبو عبدالإله]

الحمد لله أستاذي ياسر تم الحل 

فكل الشكر لكم