أكاديمية الصقر للتدريب

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

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز
المشرف المتميز
المراقب المتميز
المدير المتميز
الموضوع المتميز
القسم المتميز
بكار للأبد Eslam Abdullah لا تميز خلال هذه الفترة YasserKhalil اصدار حديث به كل جديد كنترول 2019 اكسيل اسئله واجابات




أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





نسخ صف الى صفوف مختلفه البدايه

في هذا الكود الاكثر من رائع يمسح وينسخ الصفوف دائما من صف موحد معين .. لو تمت ان تكون العناوين في الصفحات المختلفه في ص ..



21-08-2017 08:19 مساء
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 

في هذا الكود الاكثر من رائع يمسح وينسخ الصفوف دائما من صف موحد معين ..  لو تمت ان تكون العناوين في الصفحات المختلفه في صفوف مختلفه وليست صف البدايه موحد ... تكون غير عاديه ربنا يزيدكم علما وخلقا

 'هذا الكود للمحترم ياسر العربي
 ' الهدف من الكود هو نسخ صف الى صفوف تحته بالعدد المطلوب
 'وقبل النسخ يتم مسح البيانات القديمه
 'تاريخ الانشاء 30/7/2017
 'تم التعديل على الكود بواسطه المحترم ياسر خليل لوجود متطلبات جديده
'=*=*=*=*=*=*=*=*=*=*=*=*=*=*
Private Sub CommandButton1_Click()
    Dim ws      As Worksheet
    Dim sh      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim c       As Long
    
    Set ws = Sheets("بيانات الطلبة")
    'خليه عدد الطلاب
    c = ws.Range("Q1").Value
    
    'خليه الرقم السري
    If TextBox1.Text = ws.Range("F1") Then
        Me.Hide
        TextBox1.Text = ""
        MsgBox "كلمة المرور صحيحة و سيتم تنفيذ المطلوب", 64
        
        Application.ScreenUpdating = False
        Application.Calculation = xlManual
        
 'اذا كان عدد المتقدمين اقل من اتنين يتم ايقاف الكود ولا يكمل
            If ws.Range("Q1") < 2 Then
                Exit Sub
            End If
            
 For Each sh In Sheets(Array("بيانات الطلبة", "إنجاز1", "تحريرى ف 1", "تحريرى ف 2", "أعمال السنة", "كشف ناجح", "الحاله", "كنترول شيت", "رصد الترم الثانى", "كنترول شيت (2)", "رصد الترم الأول", "كشف الدور الثاني"))
                lr = IIf(LastOccupiedRowNum(sh) = 9, 9, LastOccupiedRowNum(sh))
                lc = LastOccupiedColNum(sh)
                
       'حذف البيانات الموجودة في النطاق المحدد
        sh.Range("A10").Resize(Rows.Count - 9, lc).Clear
                       
'نسخ الصف التاسع لكل شيت من حيث عدد الاعمدة الى العدد المحدد بعدد المتقدمين
    sh.Range("A9").Resize(1, lc).AutoFill Destination:=sh.Range("A9").Resize(c, lc)
            Next sh
            
            Application.GoTo ws.Range("A1")
        Application.Calculation = xlAutomatic
        Application.ScreenUpdating = True
        Unload Me
    Else
        MsgBox "عفواً كلمة المرور خاطئه و لن يتم تنفيذ المطلوب", vbExclamation
        TextBox1.Text = ""
        TextBox1.SetFocus
    End If
End Sub

Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedRowNum = lng
End Function

Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
    Dim lng As Long
    
    If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
        With Sheet
            lng = .Cells.Find(What:="*", After:=.Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        End With
    Else
        lng = 1
    End If
    
    LastOccupiedColNum = lng
End Function
'==================================
Private Sub UserForm_Click()
End Sub

يعني مثلا الصفحه الاولى والتانيه تبدا من الصف التاسع..
والصفحه التالته من الصف السابع..
والرابعه من الصف الثامن .. يعني بدايات مختلفه جزاكم الله خيرا



توقيع :ناصر سعيد
جزاكم الله خيرا




21-08-2017 08:53 مساء
مشاهدة مشاركة منفردة [1]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 5060
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 14
يتابعهم : 0
يتابعونه : 331
قوة السمعة : 14720
الاعجاب : 5494
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
السلام عليكم أخي العزيز ناصر
يرجى إرفاق ملف بسيط معبر عن الطلب .. لتتضح صورة طلبك بشكل أكبر





21-08-2017 09:20 مساء
مشاهدة مشاركة منفردة [2]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 5060
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 14
يتابعهم : 0
يتابعونه : 331
قوة السمعة : 14720
الاعجاب : 5494
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
تفضل أخي ناصر ملف مبسط وفيه كود مشروح بالتفصيل .. يرجى دراسة الكود دراسة جادة لتتعلم منه ولتستطيع التعديل عليه فيما بعد
Sub Test_CopyRow_Procedure()
    'أمثلة لكيفية استخدام الإجراء الفرعي
    '----------------------------------
    
    CopyRow "Data", 5
    CopyRow "Report", 7
    CopyRow "Final", 5
End Sub

Sub CopyRow(sSheet As String, sRow As Long)
'هذا الإجراء العام يقوم بنسخ آخر صف بعدد محدد من الصفوف بناءً على
'عدد 2 بارامتر الأول يمثل اسم ورقة العمل والثاني يمثل صف البداية
'--------------------------------------------------------------

    'تعريف المتغيرات
    Dim ws      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim i       As Long

    'جملة لتجنب حدوث خطأ عند تعيين ورقة العمل
    On Error Resume Next
        
        'تعيين المتغير ليحمل ورقة العمل المعنية
        Set ws = Sheets(sSheet)
        
    'جملة لاستعادة خاصية تتبع الأخطاء
    On Error GoTo 0

    'إذا لم تكن هناك ورقة عمل بهذا الاسم
    If ws Is Nothing Then
    
        'تظهر رسالة تفيد بذلك ثم يتم الخروج من الإجراء الفرعي
        MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    'تعطيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
    
        'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل
        i = Sheets("Sheet1").Range("D5").Value
        
        'تحديد رقم آخر عمود بناءً على الصف الذي تم وضعه في البارامتر الثاني
        lc = ws.Cells(sRow, Columns.Count).End(xlToLeft).Column
        
        'نسخ الصف المطلوب بدايةً من العمود الأول إلى آخر عمود
        ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy
        
        'تحديد رقم آخر صف بورقة العمل المعنية مضافاً إليها 1 ليبدأ من أول صف جديد
        lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        
        'لصق البيانات التي تم نسخها بداية من أول صف فارغ وبامتداد عدد الصفوف المقررة
        ws.Range("A" & lr).Resize(i).PasteSpecial xlPasteAll
        
        'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه
        ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents
        
        'سطر للذهاب لأول خلية في ورقة العمل بعد القيام بعملية النسخ
        Application.Goto ws.Range("A1")
    
    'استعادة خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

 
 
 
  Copy Specific Row In Specific Sheets.rar   تحميل rar مرات التحميل :(5)
الحجم :(16.485) KB



تم تحرير المشاركة بواسطة :YasserKhalil
بتاريخ:21-08-2017 09:20 مساء


أثارت هذه المشاركة إعجاب: تاج الدين،




21-08-2017 09:31 مساء
مشاهدة مشاركة منفردة [3]
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
 
 
  نسخ صفوف واضافه طالب - نسخة.rar   تحميل rar مرات التحميل :(5)
الحجم :(235.88) KB


أثارت هذه المشاركة إعجاب: تاج الدين،


توقيع :ناصر سعيد
جزاكم الله خيرا



21-08-2017 09:34 مساء
مشاهدة مشاركة منفردة [4]
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
بالنسبه لكودك اخي الكريم ياسر خليل ستتم دراسته وافادتكم ان شاء الله بالنتيجه



توقيع :ناصر سعيد
جزاكم الله خيرا



21-08-2017 09:44 مساء
مشاهدة مشاركة منفردة [5]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 5060
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 14
يتابعهم : 0
يتابعونه : 331
قوة السمعة : 14720
الاعجاب : 5494
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
بارك الله فيك أخي العزيز ناصر ..
أفضل دائماً أن يكون الملف المرفق بسيط لتتضح صورة المشكلة بشكل عام وهذا يجعل من المشكلة أمراً بسيطاً وسهلاً إن شاء الله
المهم ادرس الملف واقرأ التعليقات في الكود بشكل جيد لتعرف الخطوات التي تتم وتعالج المشكلة 





21-08-2017 10:21 مساء
مشاهدة مشاركة منفردة [6]
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه

        'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه
        ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents

في هذا السطر يوجد ClearContents فاين الجزئيه التي لاتمسح المعادلات من فضلك ؟



توقيع :ناصر سعيد
جزاكم الله خيرا



21-08-2017 10:42 مساء
مشاهدة مشاركة منفردة [7]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 5060
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 14
يتابعهم : 0
يتابعونه : 331
قوة السمعة : 14720
الاعجاب : 5494
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
هذه الجزئية أخي ناصر تتعامل مع الثوابت فقط وليس المعادلات
.SpecialCells(xlCellTypeConstants, 3)





21-08-2017 11:24 مساء
مشاهدة مشاركة منفردة [8]
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه

Option Explicit

Sub Test_CopyRow_Procedure()
    'أمثلة لكيفية استخدام الإجراء الفرعي
    '----------------------------------
 
    CopyRow "بيانات الطلبة", 9
    CopyRow "رصد الترم الأول", 10
    CopyRow "كنترول شيت (2)", 11
    CopyRow "رصد الترم الثانى", 10
    CopyRow "كنترول شيت", 10
    CopyRow "الحاله", 11
    CopyRow "كشف ناجح", 9
    CopyRow "أعمال السنة", 7
    CopyRow "تحريرى ف 2", 7
    CopyRow "إنجاز1", 7
    CopyRow "بيانات الطلبة", 9
    CopyRow "تحريرى ف 1", 7
   ' CopyRow "بيانات الطلبة", 9
    CopyRow "كشف الدور الثاني", 9


End Sub

Sub CopyRow(sSheet As String, sRow As Long)
'هذا الإجراء العام يقوم بنسخ آخر صف بعدد محدد من الصفوف بناءً على
'عدد 2 بارامتر الأول يمثل اسم ورقة العمل والثاني يمثل صف البداية
'--------------------------------------------------------------

    'تعريف المتغيرات
    Dim ws      As Worksheet
    Dim lr      As Long
    Dim lc      As Long
    Dim i       As Long

    'جملة لتجنب حدوث خطأ عند تعيين ورقة العمل
    On Error Resume Next
        
        'تعيين المتغير ليحمل ورقة العمل المعنية
        Set ws = Sheets(sSheet)
        
    'جملة لاستعادة خاصية تتبع الأخطاء
    On Error GoTo 0

    'إذا لم تكن هناك ورقة عمل بهذا الاسم
    If ws Is Nothing Then
    
        'تظهر رسالة تفيد بذلك ثم يتم الخروج من الإجراء الفرعي
        MsgBox "Sheet " & sSheet & " Doesn't Exists In The Workbook.", vbExclamation, "Sheet Not Found!"
        Exit Sub
    End If
    
    'تعطيل خاصية اهتزاز الشاشة
    Application.ScreenUpdating = False
    
        'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل
        i = Sheets("Sheet1").Range("Q1").Value
        
        'تحديد رقم آخر عمود بناءً على الصف الذي تم وضعه في البارامتر الثاني
        lc = ws.Cells(sRow, Columns.Count).End(xlToLeft).Column
        
        'نسخ الصف المطلوب بدايةً من العمود الأول إلى آخر عمود
        ws.Range(ws.Cells(sRow, 1), ws.Cells(sRow, lc)).Copy
        
        'تحديد رقم آخر صف بورقة العمل المعنية مضافاً إليها 1 ليبدأ من أول صف جديد
        lr = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        
        'لصق البيانات التي تم نسخها بداية من أول صف فارغ وبامتداد عدد الصفوف المقررة
        ws.Range("A" & lr).Resize(i).PasteSpecial xlPasteAll
        
        'مسح البيانات الثابتة فقط وليس المعادلات من النطاق الذي تم لصقه
        ws.Range("A" & lr).Resize(i, lc).SpecialCells(xlCellTypeConstants, 3).ClearContents
        
        'سطر للذهاب لأول خلية في ورقة العمل بعد القيام بعملية النسخ
        Application.Goto ws.Range("A1")
    
    'استعادة خاصية اهتزاز الشاشة
    Application.ScreenUpdating = True
End Sub

MzU0OTIyMQ868617%20%D9%85
 
  17 م.jpg   تحميل jpg 17 م.jpg مرات التحميل :(0)
الحجم :(68.212) KB
 




توقيع :ناصر سعيد
جزاكم الله خيرا



21-08-2017 11:27 مساء
مشاهدة مشاركة منفردة [9]
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
الكود رائع ويعمل جيدا في ملفك ولكن عند تطويعه في الملف الخاص بي اظهر الرساله السابقه من فضلك  ماذا تعني هذه الرساله ؟..




توقيع :ناصر سعيد
جزاكم الله خيرا



22-08-2017 12:05 صباحا
مشاهدة مشاركة منفردة [10]
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
السطر الموجود تحت الرساله هو اللي بيصفر



توقيع :ناصر سعيد
جزاكم الله خيرا



22-08-2017 07:02 صباحا
مشاهدة مشاركة منفردة [11]
YasserKhalil
menu_open عضوية موثقة
مراقب عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 5060
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 14
يتابعهم : 0
يتابعونه : 331
قوة السمعة : 14720
الاعجاب : 5494
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
ممكن ترفق الملف نفسه بعد وضع الكود فيه
غالباً ما ستكون المشكلة في أسماء ورقة العمل .. سأتأكد من ذلك بعد الإطلاع على الملف





22-08-2017 10:32 صباحا
مشاهدة مشاركة منفردة [12]
ناصر سعيد
menu_open
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 9
المشاركات : 140
الجنس : ذكر
تاريخ الميلاد : 1-1-1985
الدعوات : 1
يتابعهم : 0
يتابعونه : 3
قوة السمعة : 163
الاعجاب : 50
 offline 
look/images/icons/i1.gif نسخ صف الى صفوف مختلفه البدايه
عند التعديل الى هذا السطر
 'تعيين قيمة للمتغير ليساوي عدد الصفوف المقرر إدراجها في أوراق العمل
  i = Sheets("بيانات الطلبة").Range("Q1").Value
 

تغيرت الرساله التي تظهر الى

ODU2MDE462%20%D8%B5
 
  2 ص.jpg   تحميل jpg 2 ص.jpg مرات التحميل :(0)
الحجم :(75.92) KB
 




توقيع :ناصر سعيد
جزاكم الله خيرا




المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
نسخ صفوف الى صفوف مختلفه البدايه ولكن بدون مسح ناصر سعيد
7 600 YasserKhalil

الكلمات الدلالية
لا يوجد كلمات دلالية ..


 







اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.



الساعة الآن 03:00 مساء

أعلن هنا
أعلن هنا
أعلن هنا