مطلوب عمل مربع اختيارى

[حسين النجدى]

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

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

مثلا مربع اختيار فى عامود A رقم مسلسل فى B الاسم فى C تاريخ الميلاد فى D رقم السجل فى E عند الضغط على المربع الاختيارى ينقل بيانات الصف الى صفحة اخرى

 

[حسين النجدى]

هذا ما اقصده ممتاز ولكن الملف لا يعمل 

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

 

Microsoft Excel Worksheet جديد (2).xlsx

[محمد هشام.]

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

مع مزيدا من التوضيح هل البيانات المنسوخة يتم الاحتفاظ بها رغم الغاء التحديد او حدفها 

هل تريد مثلا تحديد عدة صفوف وترحيلها دفعة واحدة

تم تعديل ديسمبر 2, 2023 بواسطه محمد هشام.

[حسين النجدى]

يتم الاحتفاظ بها

الذى اريد تحديده فقط يتم نسخة

شاكرا لمساعدة حضرتك

 

[محمد هشام.]

Option Explicit
Public Property Get WSData() As Worksheet: Set WSData = Sheets("ورقة1")
End Property
Public Property Get WSDest() As Worksheet: Set WSDest = Sheets("ورقة2")
End Property

'***' اظافة  مربعات الاختيار عند التحقق من وجود قيمة في عمود الاسم
Sub Add_CheckBoxes()
Dim cell, col As Single, Cpt As CheckBox
Dim MyLeft, MyTop, MyHeight, MyWidth As Double

Application.ScreenUpdating = False
col = WSData.Range("B" & Rows.Count).End(xlUp).Row
WSData.CheckBoxes.Delete
For cell = 2 To col
    If WSData.Cells(cell, "B").Value <> "" Then
    
MyLeft = Cells(cell, "A").Left:   MyTop = Cells(cell, "A").Top
MyHeight = Cells(cell, "A").Height: MyWidth = Cells(cell, "A").Width
WSData.CheckBoxes.Add(MyLeft, MyTop, MyWidth, MyHeight).Select
 With Selection
     .Caption = "": .Value = xlOff: .Display3DShading = False
 End With
[A1].Select
End If
Next cell
Application.ScreenUpdating = True
End Sub

'**** نسخ الاعمدة المحددة
Sub CopyRows()
Dim derlig&, r&, Lr&, Cpt As CheckBox
For Each Cpt In WSData.CheckBoxes
If Cpt.Value = 1 Then
For r = 1 To Rows.Count
    If Cells(r, 1).Top = Cpt.Top Then
        With WSDest
        .Range("A2:A" & Rows.Count).ClearContents
           Lr = .Range("B" & Rows.Count).End(xlUp).Row + 1
            ' عمود الاسم
            .Range("B" & Lr) = _
            WSData.Range("B" & r).Value
            
         'في حالة الرغبة بنسخ  عدة اعمدة قم بظبط السطر التالي بما يناسبك
'      .Range("B" & Lr & ":F" & Lr) = _
'                   WSData.Range("B" & r & ":F" & r).Value

'**** تسلسل البيانات المنسوخة
derlig = WSDest.Range("B" & WSDest.Rows.Count).End(xlUp).Row
WSDest.Range("A2").Value = 1
WSDest.Range("A2:A" & derlig).DataSeries , xlDataSeriesLinear
    
          End With
        Exit For
     End If
   Next r
 End If
Next
On Error Resume Next
WSData.CheckBoxes.Value = False
On Error GoTo 0
End Sub

 

 

 

Microsoft Excel Worksheet جديد (2).xlsm

تم تعديل ديسمبر 2, 2023 بواسطه محمد هشام.