نجوم المشاركات

بسم الله الرحمن الرحيم يَا أَيُّهَا النَّاسُ إِنَّا خَلَقْنَاكُم مِّن ذَكَرٍ وَأُنثَى وَجَعَلْنَاكُمْ شُعُوباً وَقَبَائِلَ لِتَعَارَفُوا إِنَّ أَكْرَمَكُمْ عِندَ اللَّهِ أَتْقَاكُمْ إِنَّ اللَّهَ عَلِيمٌ خَبيرٌ صدق الله العظيم أخوتي الكرام هذا الموضوع مخصص للتعارف بين أعضاء المنتدي و نأمل أن يزيدنا قربا و محبة و تعارف و أرجو أن تكون بداية المواضيع بنفس نسق المشاركة التالية قدر الامكان مع تحياتي

أخواني وأخواتي الأعزاء تحية طيبة وبعد ،،،،،،،، أقدم اليوم إليكم برنامج الرواتب والموارد البشرية حسب قانون الخدمة المدنية الفلسطيني قبل التعديل ، وأتمنى أن تستفيدوا من الأفكار والبرمجة الموجودة بداخله حيث أنه مفتوح المصدر. توجد به حركة الرواتب من 30/4/2004 وحتى 31/12/2005 حيث كان الاحتساب يبدأ بتاريخ نهاية كل شهر مثال ذلك 30/4/2004 أو 31/5/2004 أو 30/6/2004 أو 31/12/2005 وهكذا فإذا أردت طباعة أي استمارة راتب مثلاً كل ما عليك أن تدخل رقم الموظف في خانة من .. الى .. وتاريخ الاحتساب. أتمنى لكم التوفيق Salaries_2005.rar

السلام عليكم ورحمة الله وبركاته كل عام وانتم جميعا بخير اذكار عظيمة (هدية الايام المباركة) المصدر http://www.azkary.com/ المرفق 2003 اذكار.rar

السلام عليكم يتم استخراج البيانات لكل القيم الفريدة في العمود بي للورقة Data1 Option Explicit Private Const ContColmn As Integer = 5 '====================================================== '====================================================== Sub kh_Report() Dim obj As Object Dim Ar() As Double, XX() As Double, X() As Double Dim v As Double, vv As Double Dim Rng As Range Dim LastRow As Long, iCont As Long Dim i As Long, ii As Long, iii As Long, R As Long Dim C As Integer Dim tx '''''''''''''''''''''' On Error GoTo kh_ex Set obj = CreateObject("Scripting.Dictionary") ''''''''''''''''''''' '============================================ kh_Clear '============================================ With æÑÞÉ2 LastRow = .Cells(Rows.Count, "A").End(xlUp).Row Set Rng = .Range("A1:D" & LastRow) End With '============================================ ReDim Ar(1 To ContColmn - 1) For C = 1 To ContColmn - 1 Ar(C) = Range("B1").Cells(1, C).Value Next tx = Range("F1").Value '============================================ kh_Application False With Rng .Sort .Columns(2), xlAscending For i = 1 To .Rows.Count v = .Cells(i, "B").Value vv = Val(.Cells(i, "D")) If obj.Exists(v) Then iii = obj(v) '''''''''''''''''' If .Cells(i, "C").Value = tx Then For C = 1 To ContColmn - 1 If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = XX(C + 1, iii) + vv Next End If Else ii = ii + 1 ReDim Preserve XX(1 To ContColmn, 1 To ii) obj.Add v, ii '''''''''''''''''' XX(1, ii) = v If .Cells(i, "C").Value = tx Then For C = 1 To ContColmn - 1 If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = vv Next End If End If Next End With ''''''''''''''''''''''''''''''' iCont = obj.Count If iCont Then Erase Ar ReDim Ar(1 To ContColmn - 1) ReDim X(1 To iCont, 1 To ContColmn) For i = 1 To iCont X(i, 1) = XX(1, i) For C = 1 To ContColmn - 1 Ar(C) = Ar(C) + XX(C + 1, i) X(i, C + 1) = Ar(C) Next Next With Range("A2").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = X End With ''''''''''''''''''''''''' End If '============================================ kh_ex: kh_Application True '''''''''''''''''' '''''''''''''''''' '''''''''''''''''' Set obj = Nothing Set Rng = Nothing Erase XX, X, Ar '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear End If End Sub شاهد المرفق 2010 Ex1.rar

هل تريد شرح للكود

على الرغم مخالفتكم كما أشار الأخ ضاحى فنظرا لحداثة انضمامكم قمت بالرد عليكم بعد أن عدلت العنوان برجاء اتباع قواعد المشاركة المكافأة.rar

السلام عليكم أخي جمال تفضل المرفق به الشرح كيفية عمل دالة خاصة.rar

الاسم : طارق حنيدق الحماحمى سنة الميلاد : 1962 م المهنة : مهندس مدني و أعمل فى مجال إدارة المشاريع الهندسية التعليم : بكارولويس هندسة مدنية 1984 - هندسة القاهرة الحالة الاجتماعية : متزوج و رزقني الله ب 4 أطفال بلد الجنسية / الاقامة : مصر / ح. المعادى أقسام الاهتمام فى المنتدي : الأكسيس و الإكسيل أجيد إستخدام برامج ادارة المشروعات مثل Primavera و Expedition بالاضافة الي بعض البرامج الهندسبة