الـعيدروس

السلام عليكم هل تقصد اضافة عمود يقوم بعمل مسلسل حسب رقم الحجره ؟ واذا كان المقصد المسلسل في عمود رقم الحجره كيف اعرف هذا الاسم ينتمي لأي حجره ! جرب هذا الكود حسب فهمي لطلبك Sub Ali_Num() Dim Sw As Worksheet Dim R, Rb, Rb_To, Vl, i Set Sw = ورقة1 With ورقة18 For R = 5 To .Cells(.Rows.Count, 1).End(xlUp).Row If .Cells(R, 1) <> Empty Then Rb = Val(.Cells(R, 3)) Rb_To = Val(.Cells(R, 4)) Vl = Val(.Cells(R, 1)) For i = Rb To Rb_To Sw.Cells(i + 1, "I") = Vl Next End If Next End With End Sub

مجرد تسمية للكود بإمكانك تسمية ماتشاء مثلاً Sub Naser_Almsre () اسم فقط هذا يرمز الى تحديد الخلايا التي تحتوي على صيغه الملاحظ انا عمود Am يحتوي على صيغ فقط لذا عبرنا عن التي تحتوي على صيغه اما بخصوص مرفقك الاخير لم افهم طلبك بخصوص الجدول هل ملفك الاساسي به جداول وبينها فراغات اما جداول وبينها اسطر قيم ؟

جرب هذا التعديل هذا التعديل بيتماشي مع ملفك كما هو بوضعه الحالي Dim Sh As Worksheet Sub Ali_Prnt() Dim R As Long Dim Ar Dim Rn As Range, Rn1 As Range Set Sh = ActiveSheet '********************************************** On Error Resume Next Application.EnableEvents = True With Sh II = .PageSetup.PrintArea For R = 1 To .VPageBreaks.Count Ro = .VPageBreaks(R).Location.Row Cl = .VPageBreaks(R).Location.Column Ar = .Range(.PageSetup.PrintArea) Lr = UBound(Ar, 2) + 1 Rw = UBound(Ar, 1) + 1 Set Rn = .Range(Cells(Ro, 2), Cells(Rw, Cl - 1)) Set Rn1 = .Range(Cells(Ro, Cl), Cells(Rw, Lr)) Ali_Rest With .PageSetup .PrintArea = Rn.Address .RightHeader = Sheets("الاساسية").Range("A1").Value & Chr(13) & Sheets("الاساسية").Range("A2").Value .LeftHeader = Sheets("الاساسية").Range("B1").Value & Chr(13) & Sheets("الاساسية").Range("B2").Value .RightFooter = Sheets("الاساسية").Range("A3").Value & Chr(13) & Sheets("الاساسية").Range("A4").Value .CenterFooter = Sheets("الاساسية").Range("b3").Value & Chr(13) & Sheets("الاساسية").Range("b4").Value End With .PrintPreview Ali_Rest With .PageSetup .PrintArea = Rn1.Address .LeftHeader = Sheets("الاساسية").Range("c1").Value & Chr(13) & Sheets("الاساسية").Range("c2").Value .LeftFooter = Sheets("الاساسية").Range("c3").Value & Chr(13) & Sheets("الاساسية").Range("c4").Value End With .PrintPreview Next R .PageSetup.PrintArea = II End With Application.EnableEvents = False '********************************************** On Error GoTo 0 End Sub Private Sub Ali_Rest() With Sh With .PageSetup .RightHeader = "" .RightFooter = "" .CenterFooter = "" .LeftHeader = "" .LeftFooter = "" End With End With Set Sh = Nothing End Sub

كود رائع اخي ياسر خليل تقبلو مروري

مانوع الاوفيس عندك 2007 ام 2003 عندي 2007

السلام عليكم Sub Ali_T() Set Ws = Sheets("salary") L = Split(Ws.UsedRange.Address, "$")(4) Union(Ws.Range("C8:C" & L).SpecialCells(2), _ Ws.Range("Am8:Am" & L).SpecialCells(-4123)).Copy Sheets("Total ").[J8] End Sub

في حدث Thisworkbook ضع الكود التالي Private Sub Workbook_BeforePrint(Cancel As Boolean) Cancel = True End Sub

السلام عليكم جرب هذا الكود Sub Ali_Prnt() Dim R As Long Dim Num As Long '********************************************** On Error Resume Next With ActiveSheet .PageSetup.PrintArea = .PageSetup.PrintArea ActiveWindow.View = xlPageBreakPreview For R = 1 To .HPageBreaks.Count + 1 Num = Num + 1 If Num Mod 2 <> 0 Then With .PageSetup .RightHeader = Sheets("الاساسية").Range("A1").Value & Chr(13) & Sheets("الاساسية").Range("A2").Value .RightFooter = Sheets("الاساسية").Range("A3").Value & Chr(13) & Sheets("الاساسية").Range("A4").Value .CenterFooter = Sheets("الاساسية").Range("b3").Value & Chr(13) & Sheets("الاساسية").Range("b4").Value End With .PrintPreview Else With .PageSetup .LeftHeader = Sheets("الاساسية").Range("c1").Value & Chr(13) & Sheets("الاساسية").Range("c2").Value .LeftFooter = Sheets("الاساسية").Range("c3").Value & Chr(13) & Sheets("الاساسية").Range("c4").Value End With .PrintPreview End If Next R End With ActiveWindow.View = xlNormalView '********************************************** On Error GoTo 0 End Sub لاتنسى تحط علامة ' في كود حدث الطباعة 'Private Sub Workbook_BeforePrint(Cancel As Boolean) 'With ActiveSheet.PageSetup '' على خليتين لكل واحدة يعني يمين خليتين يسار خليتين وسط خليتين لتذيل وراس الصفحة ' .RightHeader = Sheets("الاساسية").Range("A1").Value & Chr(13) & Sheets("الاساسية").Range("A2").Value ' .CenterHeader = Sheets("الاساسية").Range("b1").Value & Chr(13) & Sheets("الاساسية").Range("b2").Value ' .LeftHeader = Sheets("الاساسية").Range("c1").Value & Chr(13) & Sheets("الاساسية").Range("c2").Value ' .RightFooter = Sheets("الاساسية").Range("A3").Value & Chr(13) & Sheets("الاساسية").Range("A4").Value ' .CenterFooter = Sheets("الاساسية").Range("b3").Value & Chr(13) & Sheets("الاساسية").Range("b4").Value ' .LeftFooter = Sheets("الاساسية").Range("c3").Value & Chr(13) & Sheets("الاساسية").Range("c4").Value 'End With 'End Sub تحياتي

ارفق مثال عملي لما تريد كما الملف عندك وحط بيانات وهميه ليتم التطبيق عليه مع شرح مبسط تحياتي

السلام عليكم بارك الله فيك استاذ طارق محمود ونفع بعلمك

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

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

السلام عليكم اطلع المرفق به مثال مااقصد اضفت ورقة كجدول لجميع ايام الشهر ومن خلال الخليه الصفراء تختار الموظف المراد تحياتي مثال_1.rar

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

ارفق الملف هنا عبر المنتدى لم استطيع تنزيله اضغط الملف وارفقه هنا

اضن عبر دالة GetCursorPos محاولات لم تنجح api ليس لها الا جعفر الطريبق بارك الله فيه

السلام عليكم لم افهم طلب الاخ مشعل الا من ردودكم بارك الله فيكم اخي سليم واخي ياسر كنت اضن التنازلي بالقيمة وليس بعدد التكرار تقبلو تحياتي هذا ماعملت عليه حسب القيمة Sub Ali_A() Dim Rn As Range Dim Ar, S_A, y, I, J, It On Error Resume Next Set Rn = Range("A2:D21") Set Ap = Application.WorksheetFunction: ii = 2 With CreateObject("scripting.dictionary") For Each It In Rn y = .Item(It.Value) Next Ar = Split(Join(.Keys, ","), ",") For I = LBound(Ar) To UBound(Ar) For J = I + 1 To UBound(Ar) If Ar(I) < Ar(J) Then S_A = Ar(J): Ar(J) = Ar(I): Ar(I) = S_A Next J If Ap.CountIf(Rn, Ar(I)) > 0 Then _ Cells(ii, "G") = " تكرر العدد " & Ap.CountIf(Rn, Ar(I)) & " مرات ": Cells(ii, "F") = Ar(I): ii = ii + 1 Next End With End Sub

السلام عليكم الاخ والاستاذ ياسر فتحي البنا الف الف مبروك على الترقيه والى مزيد من التقدم والرقى ان شاء الله تقبل مروري

انت قلت اضف هذا السطر Application.Calculate بعد السطر Sheets(ComboBox1.Value).Delete ليكون كود ال CommandButton1_Click كالتالي بعد الاضافه Private Sub CommandButton1_Click() Dim C As Range Dim Fir Application.DisplayAlerts = False If Sheets.Count > 1 And ComboBox1.Value <> "" Then On Error Resume Next With ActiveSheet.Columns(2) Set C = .Find(ComboBox1, LookIn:=xlValues) If Not C Is Nothing Then Fir = C.Address Do C.EntireRow.Delete Set C = .FindNext(C) Loop While Not C Is Nothing And C.Address <> Fir End If End With Sheets(ComboBox1.Value).Delete Application.Calculate End If Application.DisplayAlerts = True UserForm_Initialize End Sub

شاهد الشرح فالمرفق هكذا عمل الكود توضيح.rar

شاهد المرفق اكتب القيد وانقر على الزر مع مرعاة الخليه التي لونها اصفر تحدد بها الشهر بعد التجربه وضح مالذي تريده ان يتعدل تحياتي يومية الأمريكية_11.rar

وين شرط الشهر في قيد اليومية في اي خليه وشرط التاريخ في صفحة الشهر مثلاً يناير اي عمود كالصورة في المرفق المحدد بالاحمر مثلاً هو التاريخ المطلوب الى اي عمود يرحل القيم والمبلغ وهو بالاساس به قيم سابقه ؟ بصراحه لم افهم طلبك

تفضل Public Sub A_Add() Dim Sh As Worksheet, Sht As Worksheet Dim R As Range Set Sht = Sheets("Sheet2") Set Sh = Sheets("Sheet1") i = 1 Lr = Sh.Cells(Rows.Count, 1).End(xlUp).Row For Each R In Sh.Range("A1:J" & Lr).Rows A = Join(Application.Index(R.Value, 0), ",") A = Formt(A, Split(A, ",")(4)): A = Formt(A, Split(A, ",")(5)) B = Replace(A, "ES", "MR") B = Mid(B, 1, InStr(1, B, Split(B, ",")(3)) - 1) & Adm("0.00,", 3) & Split(B, ",")(7) & "." & String(2, "0") & Adm(",0.00", 2) A = A & String(3, "0") ii = Sht.Cells(Rows.Count, 1).End(xlUp).Row + 1 Sht.Cells(ii, 1) = Choose(1, A, B) Sht.Cells(ii + 1, 1) = Choose(2, A, B) i = i + 1: ii = ii + 1 Next End Sub Private Function Formt(R, Nm) Formt = Replace(R, Nm, Format(Nm, "yyyy-mm-dd")) End Function Private Function Adm(Strn$, Ln&) Adm = Application.Rept(Strn, Ln) End Function

تفضل Class_1.rar

ادرج 30 سطر على عدد الايام واستخدم دالة Sum لحساب التأخير لجميع الايام