نقل بيانات من ورقة ال ورقة حسب البيانات المختارة من الليست بوكس

[سعد الفقير]

السلام عليكم:

السؤال موجود في ورقة Quires

 

هل بالامكان الاختيار من الليست بوكس الموجودة في ورقة Quires وادراج بيانات الموظفين حسب البيانات المدخله في الورقة SQ علما بان البيانات الموجودة في الليست بوكس ماخوذة من الخلية( J )في ورقة ال SQ ….. بمعنى اذا اخترت من الليست بوكس مرضية سوف يدرج جميع الموظفين الذين يتمتعون باجازة مرضية حسب المدخلات في ورقة ال SQ المدرجة في الخلية J      .... ايضا يتم ادراج العدد التسلسلي اتوماتيكيا عند وجود بيانات ويتم تسطير الجدول اتوماتيكيا عند وجود بيانات للموظفين......................              ولكم جزيل الشكر

Copy of 1212.rar

افضل الحل ان يكون في الاكواد VBA

[سعد الفقير]

up

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

أخي الكريم سعد

يرجى تغيير اسم الظهور بشكل مناسب ليظهر اللقب مع الاسم

إليك الكود التالي يوضع في حدث ورقة العمل المسماة Quires ..بمجرد الاختيار من الخلية H9

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim LR As Long, LRQ As Long, Cell As Range
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("H9")) Is Nothing Then
        Application.ScreenUpdating = False
            With Sheets("Quires").Range("B15:G1000")
                .Offset(1).ClearContents
                .Borders.LineStyle = xlNone
            End With
    
            With Sheet1
                .Rows(1).AutoFilter
                .Rows(1).AutoFilter 10, "=" & Sheets("Quires").Range("H9")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row
                If LR > 1 Then
                    Union(.Range("D2:F" & LR), .Range("I2:I" & LR), .Range("K2:K" & LR)).Copy
                    Sheets("Quires").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
                End If
                .Rows(1).AutoFilter
            End With
    
            With Sheets("Quires")
                LRQ = .Range("C" & .Rows.Count).End(xlUp).Row
                If LRQ > 15 Then
                    For Each Cell In .Range("B16:B" & LRQ)
                        Cell = Cell.Row - 15
                    Next Cell
                End If
                With .Range("B15").CurrentRegion
                    .Borders.Weight = xlThin
                    .BorderAround Weight:=xlThick
                End With
                .Range("H9").Select
            End With
        Application.ScreenUpdating = True
    End If
End Sub

وإليك الملف المرفق

تقبل تحياتي

Filter Copy Specific Data YasserKhalil.rar

[سعد الفقير]

ماشاء الله زادك الله من علمه اخي ياسر. مبدع

هل بالامكان شرح الكود ليتسنى لي فهمة والتعلم منه. وفقك الله.

تم تعديل أكتوبر 23, 2015 بواسطه سعد الفقير

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

أخي الكريم سعد

حاول الإطلاع على الكود ومحاولة فهم الأسطر

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

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

الكود بشكل عام  .. مسح النطاق الذي ستوضع به النتائج

عمل فلترة للبيانات في الورقة الأولى بناءً على قيمة الخلية H9

نسخ الأعمدة التي تمت تصفيتها

وأخيراً ترقيم النتائج وتسطير الجدول

[سعد الفقير]

أخي ياسر قمت بمراجعة الكود وعدلت علية لكي يعمل معي على الملف الاصلي ولاكن لم يعمل. نسخة مرفقة من الملف الاصلي. 

 

الكود المعد اسفل وتم تعديل ما تم تلوينة بالون الاحمر. لماذا لم يعمل. شاكر حسن تعاونك.

 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim LR As Long, LRQ As Long, Cell As Range
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("H9")) Is Nothing Then
        Application.ScreenUpdating = False
            With Sheets("Quires").Range("B15:G1000")
                .Offset(1).ClearContents
                .Borders.LineStyle = xlNone
            End With
    
            With Sheets("SQ")
                .Rows(1).AutoFilter
                .Rows(1).AutoFilter 11, "=" & Sheets("Quires").Range("H9")
                LR = .Range("A" & .Rows.Count).End(xlUp).Row
                If LR > 1 Then
                    Union(.Range("D2:E" & LR), .Range("G2:G" & LR), .Range("J2:J" & LR), .Range("L2:L" & LR)).Copy
                    Sheets("Quires").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
                End If
                .Rows(1).AutoFilter
            End With
    
            With Sheets("Quires")
                LRQ = .Range("C" & .Rows.Count).End(xlUp).Row
                If LRQ > 15 Then
                    For Each Cell In .Range("B16:B" & LRQ)
                        Cell = Cell.Row - 15
                    Next Cell
                End If
                With .Range("B15").CurrentRegion
                    .Borders.Weight = xlThin
                    .BorderAround Weight:=xlThick
                End With
                .Range("H9").Select
            End With
        Application.ScreenUpdating = True
    End If
End Sub

 

 

 

تم تعديل أكتوبر 23, 2015 بواسطه سعد الفقير
ل

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

جرب الكود في موديول عادي واربطه بزر أمر سيعمل معك إن شاء الله

Sub FilterSpecific()
    Application.ScreenUpdating = False
    With Sheets("Quires").Range("B15:G1000")
        .Offset(1).ClearContents
        .Borders.LineStyle = xlNone
    End With

    With Sheets("SQ")
        .Rows(1).AutoFilter
        .Rows(1).AutoFilter 11, "=" & Sheets("Quires").Range("H9")
        LR = .Range("A" & .Rows.Count).End(xlUp).Row
        If LR > 1 Then
            Union(.Range("D2:E" & LR), .Range("G2:G" & LR), .Range("J2:J" & LR), .Range("L2:L" & LR)).Copy
            Sheets("Quires").Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
        End If
        .Rows(1).AutoFilter
    End With

    With Sheets("Quires")
        LRQ = .Range("C" & .Rows.Count).End(xlUp).Row
        If LRQ > 15 Then
            For Each Cell In .Range("B16:B" & LRQ)
                Cell = Cell.Row - 15
            Next Cell
        End If
        With .Range("B15").CurrentRegion
            .Borders.Weight = xlThin
            .BorderAround Weight:=xlThick
        End With
        .Range("H9").Select
    End With
    Application.ScreenUpdating = True

End Sub

لا أدر ما السبب في عدم عمل الكود في حدث الورقة لديك ..

قد تكون هناك مشكلة في مكان ما أو لربما لأن خلية الشرط مدمجة ...كل الاحتمالات واردة

[سعد الفقير]

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

[سعد الفقير]

أخي ياسر ظهرت مشكلة وهي عدم الترقيم التلقائي اما الباقي فيعمل مئة بالمئة.

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

أخي الكريم أين الملف المرفق الأخير الخاص بك؟

الترقيم يعمل في الملف الأول الذي قمت بإرفاقه لك بشكل صحيح

يرجى مراجعة الكود الأول مرة أخرى للتأكد

تقبل تحياتي

[سعد الفقير]

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

 

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

 

تم تعديل أكتوبر 23, 2015 بواسطه سعد الفقير

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

أضف سطر الإعلان عن المتغيرات في أول الموديول

Dim LR As Long, LRQ As Long, Cell As Range

وإن شاء الله يتم حل المشكلة

تقبل تحياتي

[سعد الفقير]

لا استطيع الا ان اقول لله درك وزادك من علمة مميز كعادتك. تم حل المشكلة.

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

أخي الغالي سعد الفقير إلى الله

الحمد لله الذي بنعمته تتم الصالحات

 

لي سؤال : إنت كنت مسجل قبل كدا بالمنتدى باسم "سعد رفيع" أو شيء قريب من كدا؟

تقبل تحياتي وإلى لقاء في موضوع آخر ..

[سعد الفقير]

لم يسبق بان سجلت باسم سعد الرفيع لانه لا يبت باي صله لي اما الاسم الموجود الان هو الاسم الحقيقي. 

وفقك الله اخي ياسرولنا لقاء ان شاء الله.