ترحيل بشروط

[2saad]

محتاج كود ترحيل البيانات المحددة بالأسهم من شيت (control4 ) الي شيت ( saad ) علي حسب القائمة المنسدلة الموجودة في شيت ( saad ) في العمود ( k1  )

بحيث لا يتم مسح البيانات الموجودة في ( saad ) ابتداء من العمود p  لان سيتم وضع معادلات بها

مصطفي.xlsb

[2saad]

هل من مجيب ؟

منتظر الحل من الأخوة

[أبو إيمان]

السلام عليكم

يمكنك الاطلاع على المرفق في هذه لمشاركة وإن شاء الله المعادلة تفيدك 

نفس طلبك

أو يمكنك البحث داخل المنتدى عن ترحيل البيانات أو عن شيت كنترول

أو يمك

[2saad]

شكرا جزيلا أخي الكريم

[محمد هشام.]

تفضل ووافينا بالنتيجة

Sub Filter_and_copy_with_condition() 

    Dim Rng As Range, Search As Range
    Dim Col As Variant, a As Variant, MyRng As Variant, clé As Variant
    Dim i As Long, F As Long, Cpt As Long, Lastrow As Long, Irow As Long, ColStar As Long
    
    Dim WS As Worksheet:       Set WS = Worksheets("control4")
    Dim desWS As Worksheet:    Set desWS = Worksheets("saad")
    clé = desWS.[k1]: ColStar = 10
'نطاق البيانات
Lastrow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        Set Rng = WS.Range("C16:U" & Lastrow)
        Col = Rng.Value2
        If Len([k1].Value) = 0 Then: Exit Sub
        
 With desWS
    Set Search = WS.Range("U16:U" & Lastrow).Find(clé, LookIn:=xlValues, lookat:=xlWhole)
    If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub
    
Application.ScreenUpdating = False
' تخزين البيانات القديمة
Irow = desWS.Columns("C:AT").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
For Cpt = ColStar To Irow
MyRng = desWS.Range("P10:AT" & Cpt).Value
Next
' افراغ البيانات السابقة
desWS.Range("C10:O" & Cpt).ClearContents
   ReDim a(1 To UBound(Col), 1 To UBound(Col, 2))
       End With
   For i = 1 To UBound(Col)
   ' عند تحقق الشرط
        If Col(i, 19) = clé Then
    F = F + 1
    a(F, 1) = Col(i, 1): a(F, 3) = Col(i, 3):  a(F, 4) = Col(i, 4)
  
    a(F, 6) = Col(i, 8): a(F, 8) = Col(i, 10): a(F, 9) = Col(i, 11)
     
    a(F, 10) = Col(i, 14): a(F, 11) = Col(i, 15): a(F, 12) = Col(i, 16): a(F, 13) = Col(i, 19)
    
       End If
    Next i
   [C10].Resize(F, UBound(a, 2)).Value2 = a
   For Cpt = ColStar To Irow
   desWS.Range("P10:AT" & Cpt).Value = MyRng
      Next
  Application.ScreenUpdating = True
  
End Sub

وفي حدث ورقة saad ضع الكود التالي

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("k1")) Is Nothing Then
  Call Filter_and_copy_with_condition
    End If
End Sub

 

مصطفي V2.xlsb

[2saad]

شكرا جزيلا استاذنا الفاضل وربنا يبارك فيكم جميعا

أنا عشمان في سؤال وارجو أن يتسع صدرك

أنا لو حبيت استدعي ( له دور ثان ) و ( لها دور ثان ) معا عن طريق القائمة المنسدلة

ما الذي اعدله في الكود 

أنا آسف بتعب حضرتك معاي

[محمد هشام.]

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

أنا لو حبيت استدعي ( له دور ثان ) و ( لها دور ثان ) معا عن طريق القائمة المنسدلة

  من الافضل جعل قيمة القائمة المنسدلة دور ثان فقط بدون له او لها واستخدام الكود التالي 

Sub Filter_and_copy_with_condition() 
 Dim d, j
 Dim Search As Range, clé As String, IRow As Long
 Dim WS As Worksheet:       Set WS = Worksheets("control4")
 Dim F As Worksheet:        Set F = Worksheets("saad")

    d = 9:   j = 16:   clé = "*" & F.[k1]
   
   IRow = WS.Range("U:U").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    With Application
        .Calculation = xlManual
        .ScreenUpdating = False
 
    If Len([k1].Value) = 0 Then: Exit Sub
    Set Search = WS.Range("U16:U" & IRow).Find(clé, LookIn:=xlValues, lookat:=xlWhole)
    If Search Is Nothing Then MsgBox clé & " " & "غير موجود", vbExclamation, "Admin": Exit Sub
   
    F.Range("C10:O" & Rows.Count).ClearContents
    Do Until IsEmpty(WS.Range("U" & j))
        If WS.Range("U" & j) Like clé Then
            d = d + 1
            F.Cells(d, 3).Value = WS.Cells(j, 3).Value
            F.Cells(d, 5).Value = WS.Cells(j, 5).Value
            F.Cells(d, 6).Value = WS.Cells(j, 6).Value
            F.Cells(d, 8).Value = WS.Cells(j, 10).Value
            F.Cells(d, 10).Value = WS.Cells(j, 12).Value
            F.Cells(d, 11).Value = WS.Cells(j, 13).Value
            F.Cells(d, 12).Value = WS.Cells(j, 16).Value
            F.Cells(d, 13).Value = WS.Cells(j, 17).Value
            F.Cells(d, 14).Value = WS.Cells(j, 18).Value
            F.Cells(d, 15).Value = WS.Cells(j, 21).Value
        End If
        j = j + 1
    Loop
    .Calculation = xlAutomatic
    .ScreenUpdating = True
    End With
End Sub

 

مصطفي V3.xlsb

[2saad]

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

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

وشكرا جزيلا لكل أعضاء المنتدي الكرام