كود نسخ صف من شيت لشيت تاني

[عمر طاهر]

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

طلب اجازة.xlsx

[محمد هشام.]

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

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

[عمر طاهر]

حقك على راسي
حبذا لو يتم عبر الضغط على كلمة تقديم في اخر خلية

[محمد هشام.]

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

 

[عمر طاهر]

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

[محمد هشام.]

تمام لاكن الملف يتضمن كلمة تقديم واحدة هل ورقة الرئيسية تتضمن صف واحد! ام انك ستقوم بكتابتها عند تعبئة الصفوف الموالية 

[عمر طاهر]

سأقوم انا بتعبئة لكي اتعلم واكررها

[محمد هشام.]

الموضوع ليس مسألة تعلم أخي الكريم  من متطلبات كتابة الكود معرفة ما هي النتيجة المتوقعة مسبقا  لاخذها في عين الاعتبار داخل الكود !!!!    هل مثلا عند وجود كلمة تقديم ينفذ وعند عدم وجودها لا يتم تنفيذ الكود او عدم وجود الإسم هناك عديد من الاحتمالات وهذا اول درس لك 😄😄😄

يجب ذكر النتيجة النهائية وان شاء الله سأحاول شرح الكود للاستفادة 

تم تعديل أغسطس 22 بواسطه محمد هشام.

[عمر طاهر]

لا اخي ليس كذلك
انما عند الضغط على الكلمة يتم تنفيذ الامر

[محمد هشام.]

والله اتعبتني ام أنك لغاية اللحظة لم تستوعب كلامي  لحظات سوف اقوم بكتابة الكود لينسخ اول صف على الرئيسية إلى الخلايا المطلوبة عند الظغط على خلية   K  التي تتضمن كلمة تقديم  اان الكود لايمكنه تسغيله من خلال كلمة الا بشروط انت لم تستوعبها ولك واسع النظر

[عمر طاهر]

يجوز النعاس مأثر عليي أخي 
عطيني الكود وأنا بشغله

[محمد هشام.]

تفضل اخي 

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim F As Worksheet
    Dim WS As Worksheet
    Dim rowNumber As Long
    Dim cellValue As String
    
'********التحقق من أن النقر كان على الخلية K2 فقط
    If Not Intersect(Target, Me.Range("K2")) Is Nothing Then
        Cancel = True
        
        Set F = ThisWorkbook.Sheets("إدخال")
        Set WS = ThisWorkbook.Sheets("نموذج")
        
        ' الحصول على قيمة الخلية K2
        cellValue = F.Range("K2").Value
        
 '*********التحقق مما إذا كانت كلمة "تقديم" موجودة في الخلية K2***
        If InStr(cellValue, "تقديم") > 0 Then
            ' تحديد الصف الأول
            rowNumber = 2
  '******* نسخ البيانات من الصف الأول إلى ورقة "نموذج************

            WS.Range("B2").Value = F.Cells(rowNumber, "B").Value
            WS.Range("H2").Value = F.Cells(rowNumber, "C").Value
            WS.Range("B7").Value = F.Cells(rowNumber, "D").Value
            WS.Range("B3").Value = F.Cells(rowNumber, "E").Value
            WS.Range("G3").Value = F.Cells(rowNumber, "F").Value
            WS.Range("B4").Value = F.Cells(rowNumber, "I").Value
            WS.Range("B8").Value = F.Cells(rowNumber, "J").Value
            WS.Range("E7").Value = F.Cells(rowNumber, "G").Value
            WS.Range("H7").Value = F.Cells(rowNumber, "H").Value
        Else
            MsgBox "كلمة 'تقديم' غير موجودة في الخلية K2.", vbExclamation
        End If
    End If
End Sub

 

طلب اجازة v1.xlsb

[عمر طاهر]

شكرا لك اخي الكريم 
ممنون لطفك

[محمد هشام.]

العفو اخي يسعدنا اننا استطعنا مساعدتك

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim f As Worksheet, WS As Worksheet
    Dim arrSource As Variant, arrDestination As Variant
    Dim i As Long
    
    ' التأكد من أن الخلية المحددة هي K2
    If Target.Address = "$K$2" Then
        ' التحقق من وجود كلمة "تقديم" داخل الخلية K2
        If InStr(1, Target.Value, "تقديم", vbTextCompare) > 0 Then
            ' تحديد الأوراق
            Set f = Worksheets("إدخال")
            Set WS = Worksheets("نموذج")
            
            ' تحديد الخلايا المصدر في الورقة "إدخال"
            arrSource = Array("B2", "C2", "D2", "E2", "F2", "G2", "H2", "I2", "J2")
            
            ' تحديد الخلايا الهدف في الورقة "نموذج"
            arrDestination = Array("B2", "H2", "B7", "B3", "G3", "E7", "H7", "B4", "B8")
            
            ' نسخ البيانات من الخلايا المصدر إلى الخلايا الهدف
            For i = LBound(arrSource) To UBound(arrSource)
                WS.Range(arrDestination(i)).Value = f.Range(arrSource(i)).Value
            Next i
        Else
            MsgBox "الخلية  لا تحتوي على كلمة تقديم", vbExclamation
        End If
    End If
End Sub

 

[عمر طاهر]

لاحرمنا فضلك اخي
حياك الله