ادخال وترحيل بينات اجازات العاملين ( ممكن المساعدة )

[محمد صابر الجمل]

السلام عليكم 

اولا انا عارف ان الموضوع متعب 

انا بحاول اتعلم من حضراتكم 

ارجو المساعدة في الشيت الاتي 

الملف مكون من اكثر من شيت 

ويريت كتابة الاكواد المستحدمه ولو ممكن شرحها للاستفادة 

2010.xlsx

[hegazee]

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

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

الموضوع موجود في الرابط التالي

https://www.officena.net/ib/topic/139393-قاعدة-لاجازات-العاملين/#comment-774531

[محمد صابر الجمل]

السلام عليكم 

اولا بعتذر لحضراتكم 

وشاكر جداا لمجهودكم وانا فالمنتدى للتعلم منكم 

و حاولت عمل التصميم السابق لمساعدتي في عملي 

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

 

تم تعديل بالامس في 18:08 بواسطه محمد صابر الجمل

[محمد صابر الجمل]

تقريبا 

المشكلة تقريبا هنا اللغة مش مظبوطه 

تم تعديل بالامس في 18:40 بواسطه محمد صابر الجمل

[Foksh]

هناك واحد من سببين لهذه المشكلة ..

إما أنك قمت بنسخ الأكواد ومؤشر الكتابة ( لغة الكيبورد = انجليزية ) ، وهو هنا مستبعد ..

وإما الحل الثاني ويكمن الحل بمراجعة الموضوع التالي :-

 

حيث أنصحك باستخدام آخر إصدار للأداة لضبط لغة الترميز Unicode حسب بلدك ..

في هذه المشاركة = الإصدار الأخير ..

 

[محمد صابر الجمل]

تقريبا المشكلة فالاوفيس جربته على جهاز تاني اشتغل 

[محمد صابر الجمل]

السلام عليكم 

انا حاولت ولكن توجد مشكله لا اعرف ما هي 

ممكن المساعده و حلها وطريقة الحل 

 

ماكرو.xlsm

تم تعديل منذ 11 ساعات بواسطه محمد صابر الجمل

[Foksh]

48 دقائق مضت, محمد صابر الجمل said:

السلام عليكم 

انا حاولت ولكن توجد مشكله لا اعرف ما هي 

ممكن المساعده و حلها وطريقة الحل

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

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

مشكلتك حلها تقريباً كتطبيق عملي على إصدار ويندوز 10 كما في الصورة التالية :-

 

قد تختلف قليلاً في ويندوز 11 ، ولكن المبدأ واحد ؛ وهو ذهابك الى لوحة التحكم - Control Panel ثم كما في الصورة التالية :-

  أو   

ثم اكمل باقي الخطوات كالتالي :-

 

وبعدها سيطلب منك إعادة تشغيل الكمبيوتر لتطبيق التعديلات .

[محمد صابر الجمل]

الف شكر على مجهودك 

انا اقصد مراجعة الاكواد فالشيت المرفق 

اقصد حاولت اني اعمل الشيت المرفق

هل هي تعمل بشكل صحيح ام هناك ملاحظات يمكن ان اتعلم منها 

ماكرو.xlsm

تم تعديل منذ 6 ساعات بواسطه محمد صابر الجمل

[Foksh]

7 ساعات مضت, محمد صابر الجمل said:

هل هي تعمل بشكل صحيح ام هناك ملاحظات يمكن ان اتعلم منها 

 

حسناً أخي الكريم ، ما رأيك بتصحيح جزء من المشكلة بحيث تبدأ بفهم كيفية كتابة الأكواد بشكل مفهوم ؟؟

في الكود التالي زر الإضافة في المرحلة الأولى ، وقد أضفت شرحاً بسيطاً أتمنى ان يكون مفهوماً لك . مع العلم ان معظم مشاكلك كانت في تسمية الأوراق ( الورقة1 و الورقة2 ) حيث انهما غير موجودات أساساَ . بل اسمهما الصحيح في ملفك = Sheet1 و Sheet2 ...

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

 

Private Sub Cmdadd_Click()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    
    ' هنا سنقوم بتحديد أسماء الأوراق المصدر والهدف
    Set wsSource = Worksheets("Sheet1")
    Set wsTarget = Worksheets("Sheet2")
    
    ' A هنا سنحاول البحث عن أول صف فارغ وتحديداً من العمود
    lastRow = 4  ' نبدأ من الصف 4 حسب تصميم الورقة الثانية لديك
    
    ' إذا كان الصف 4 غير فارغ ، نبحث عن أول صف فارغ أسفله
    If wsTarget.Cells(4, "A").Value <> "" Then
        lastRow = wsTarget.Cells(4, "A").End(xlDown).Row + 1
        
        ' إذا وصلنا إلى نهاية البيانات (أي لا توجد خلايا فارغة) ، نستخدم آخر صف ونضيف له 1
        If lastRow > wsTarget.Rows.Count Then
            lastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row + 1
        End If
    End If
    
    ' نتأكد من ان النطاق المحدد صحيح ويقع بين 4 وأكبر قيمة يسمح بها اكسل
    If lastRow < 4 Then lastRow = 4
    If lastRow > wsTarget.Rows.Count Then lastRow = wsTarget.Rows.Count
    
    'بدء نقل البيانات من الورقة الأولى إلى الورقة الثانية
    With wsSource
        wsTarget.Cells(lastRow, "A").Value = .Range("E5").Value
        wsTarget.Cells(lastRow, "B").Value = .Range("E7").Value
        wsTarget.Cells(lastRow, "C").Value = .Range("E9").Value
        wsTarget.Cells(lastRow, "D").Value = .Range("E11").Value
        wsTarget.Cells(lastRow, "E").Value = .Range("J5").Value
        wsTarget.Cells(lastRow, "F").Value = .Range("J7").Value
        wsTarget.Cells(lastRow, "G").Value = .Range("J9").Value
        wsTarget.Cells(lastRow, "H").Value = .Range("J11").Value
        wsTarget.Cells(lastRow, "I").Value = .Range("D13").Value
        wsTarget.Cells(lastRow, "J").Value = .Range("E13").Value
        wsTarget.Cells(lastRow, "K").Value = .Range("F13").Value
        wsTarget.Cells(lastRow, "P").Value = .Range("I13").Value
        wsTarget.Cells(lastRow, "Q").Value = .Range("J13").Value
        wsTarget.Cells(lastRow, "R").Value = .Range("K13").Value
        wsTarget.Cells(lastRow, "W").Value = .Range("D15").Value
        wsTarget.Cells(lastRow, "X").Value = .Range("E15").Value
        wsTarget.Cells(lastRow, "Y").Value = .Range("F15").Value
        wsTarget.Cells(lastRow, "AD").Value = .Range("I15").Value
        wsTarget.Cells(lastRow, "AE").Value = .Range("J15").Value
        wsTarget.Cells(lastRow, "AF").Value = .Range("K15").Value
        wsTarget.Cells(lastRow, "AK").Value = .Range("D17").Value
        wsTarget.Cells(lastRow, "AL").Value = .Range("E17").Value
        wsTarget.Cells(lastRow, "AM").Value = .Range("F17").Value
        wsTarget.Cells(lastRow, "AR").Value = .Range("I17").Value
        wsTarget.Cells(lastRow, "AS").Value = .Range("J17").Value
        wsTarget.Cells(lastRow, "AT").Value = .Range("K17").Value
        wsTarget.Cells(lastRow, "AY").Value = .Range("D19").Value
        wsTarget.Cells(lastRow, "AZ").Value = .Range("E19").Value
        wsTarget.Cells(lastRow, "BA").Value = .Range("F19").Value
        wsTarget.Cells(lastRow, "BF").Value = .Range("I19").Value
        wsTarget.Cells(lastRow, "BG").Value = .Range("J19").Value
        wsTarget.Cells(lastRow, "BH").Value = .Range("K19").Value
        wsTarget.Cells(lastRow, "BM").Value = .Range("D21").Value
        wsTarget.Cells(lastRow, "BN").Value = .Range("E21").Value
        wsTarget.Cells(lastRow, "BO").Value = .Range("F21").Value
        wsTarget.Cells(lastRow, "BT").Value = .Range("I21").Value
        wsTarget.Cells(lastRow, "BU").Value = .Range("J21").Value
        wsTarget.Cells(lastRow, "BV").Value = .Range("K21").Value
    End With
    
    ' مسح البيانات من الورقة الأولى
    On Error Resume Next  ' تجاوز الأخطاء مؤقتًا
    Set rngToClear = wsSource.Range("E5,E7,E9,E11,J5,J7,J9,J11,D13:F13,I13:K13,D15:F15,I15:K15,D17:F17,I17:K17,D19:F19,I19:K19,D21:F21,I21:K21")
    For Each cell In rngToClear
        If Not cell.MergeCells Then ' إذا لم تكن الخلية جزءً من دمج
            cell.ClearContents
        Else ' إذا كانت الخلية جزءً من دمج
            cell.MergeArea.ClearContents ' مسح محتوى نطاق الدمج بالكامل
        End If
    Next cell
    On Error GoTo 0 ' إعادة تفعيل مكتشف الأخطاء
    MsgBox "تم ترحيل البيانات بنجاح", vbInformation + vbMsgBoxRight, "تم"
End Sub