نسخ أعمدة متعددة بناء على خانات اختيار

[أنس دروبي]

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

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

أساتذتي وعلمائنا الكرام ....... في هذا الصرح العملاق والمتميز

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

المطلوب أخواني كما هو مبين وواضح من عنوان الموضوع

(نسخ أكثر من عامود بناء على خانات اختيار في فورم ولصقهم بعد ذلك في ورقة بيانات)

الشرح بالمطلوب بالتفصيل موجود في المرفق 

أتمنى أن يكون طلبي واضح وبسيط لكي لايأخذ من وقتكم الكثير

نسخ اعمدة متعددة بناء على خانة اختيار.rar

أعتذر عن رفع الملف في بداية الموضوع لا أعرف يوجد مشكلة في المتصفح 

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

[سليم حاصبيا]

جرب هذا الملف 

Copy_paste non_count_cells.rar

[أنس دروبي]

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

بارك الله فيك اخي سليم على هذا الملف الرائع 

ولكن اخي ليس هو المطلوب أبداً 

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

ليس نسخ نطاق حسب التحديد .....

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

شاهد أخي الملف  المرفق يوجد بداخله الفورم

بارك الله فيك مرة اخرى 

[أنس دروبي]

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

أخواني الكرام هل من فكرة جديدة أو عرض للأراء حول الموضوع 

يرجى الاهتمام 

 

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

أخي العزيز أنس دروبي

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

Private Sub save_pro_Click()
Dim C As Range, LR As Long
    Dim Ctrl As Control
    For Each Ctrl In Me.Controls
        If TypeName(Ctrl) = "CheckBox" Then
            If Ctrl.Value = True Then
                With Worksheets("4")
                    On Error Resume Next
                    Set C = .Rows(1).Find(What:=Ctrl.Caption, LookAt:=xlWhole)
                    On Error GoTo 0
                    If Not C Is Nothing Then
                        LR = .Cells(Rows.Count, 1).End(xlUp).Row
                        Intersect(.UsedRange, .Range(.Cells(C.Row, C.Column), .Cells(LR, C.Column))).Copy Worksheets("5").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
                    End If
                End With
            End If
        End If
    Next Ctrl
    Unload Me
End Sub

تقبل تحياتي

 

[أنس دروبي]

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

الله الله أكبر على هذا الكود الجبار والرائع والاحترافي في الأداء 

هذا هو المطلوب بكل ماتقوله الكلمة من معنى

1. Set C = .Rows(1).Find(What:=Ctrl.Caption, LookAt:=xlWhole)
 2.On Error GoTo 0
3.If Not C Is Nothing Then
4.LR = .Cells(Rows.Count, 1).End(xlUp).Row
5.Intersect(.UsedRange, .Range(.Cells(C.Row, C.Column), .Cells(LR, C.Column))).Copy 6.Worksheets("5").Cells(1,Columns.Count).End(xlToLeft).Offset(0, 1)

اخي واستاذي أبو البراء الكود فهمت منه بعض الامور 

لو سمحت وتكرمت عليي بشرح السطر رقم(1و5و6)

ماهيي فائدة ميزة (Intersect)

وشيء أخر أنه عندما قام  الكود بنسخ الاعمدة المحددة بناء على خانات الاختيار قام بتغيير ترتيب الاعمدة في الورقة رقم(5)

لاحظ ذلك قام بوضع عامود (تاريخ انتهاء العمل)قبل عامود (رقم الاقامة)

فهل يوجد تصحيح للكود لجمالية التنفيذ

 

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

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

أخي الفاضل أنس جرب التعديل التالي عله يفي بالغرض

Private Sub save_pro_Click()
    Dim C As Range, LR As Long, I As Integer, Str As String
    
    For I = 1 To 18
        If Me.Controls("CheckBox" & I).Value = True Then
            Str = Me.Controls("CheckBox" & I).Caption
            
            With Worksheets("4")
                On Error Resume Next
                Set C = .Rows(1).Find(What:=Str, LookAt:=xlWhole)
                On Error GoTo 0
                If Not C Is Nothing Then
                    LR = .Cells(Rows.Count, 1).End(xlUp).Row
                    Intersect(.UsedRange, .Range(.Cells(C.Row, C.Column), .Cells(LR, C.Column))).Copy Worksheets("5").Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
                End If
            End With
            
        End If
    Next I
    Unload Me
End Sub

تقبل تحياتي

 

[أنس دروبي]

بارك الله فيك أخي وحبيبي أبو البراء 

الكود اصبح صحيح بالفعل وينقل الأعمدة المنسوخة الى الورقة رقم (5) بالترتيب 

بارك الله فيك مرة أخرى وجزاك الله كل خير 

 

[رجب جاويش]

بعد اذن أخى الحبيب المبدع ياسر خليل

ولاثراء الموضوع

هذا كود آخر

Private Sub save_pro_Click()
Dim LC As Integer, LR As Long, I As Integer
LR = Worksheets("4").Cells(Rows.Count, 1).End(xlUp).Row
For I = 1 To 18
    If Me.Controls("CheckBox" & I).Value = True Then
        LC = Worksheets("5").Range("IV1").End(xlToLeft).Column + 1
        Range(Cells(1, I + 1), Cells(LR, I + 1)).Copy Worksheets("5").Cells(1, LC)
    End If
    Next
Unload Me
End Sub

 

تم تعديل فبراير 16, 2016 بواسطه رجب جاويش

[أنس دروبي]

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

بارك الله فيك أستاذي ومعلمي رجب جاويش

كود رائع وبسيط وأداء متميز وأكثر من رائع

بارك الله فيك مرة اخرى وجزاك الله كل خير

[رجب جاويش]

أخى الفاضل أنس

جزاك الله خيرا على هذه الكلمات الطيبة

 

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

جزيت خيراً أخي الغالي رجب .. وربنا ما يحرمنا منك ولا من إبداعاتك المتواصلة

تقبل وافر تقديري واحترامي