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

السلام عليكم ورحمة الله هذا الكود لاستدعاء اسم السيارة بناءا على رقمها اما موضوع تحويل التاريخ من هجرى الى ميلادى اتمنى ان بساعدك فى احد الاخوة لضيق الوقت لدى Sub CarsNames() Dim ws As Worksheet, Sh As Worksheet Dim LR As Long, i As Long Dim Car As String, CarNum As String Dim WF As Variant Set ws = Sheets("Sheet1") Set Sh = Sheets("Plate_No") Set WF = WorksheetFunction LR = ws.Range("A" & Rows.Count).End(xlUp).Row i = 6 Do While i <= LR CarNum = ws.Range("J" & i).Value Car = WF.Index(Sh.Range("A2:B" & Sh.Range("B" & Rows.Count).End(3).Row), _ WF.Match(CarNum, Sh.Range("B2:B" & Sh.Range("B" & Rows.Count).End(3).Row), 0), 1) ws.Range("I" & i) = Car i = i + 1 Loop End Sub

نعم أخي الكريم يمكن عمل ذلك عن طريق الكود التالي DoCmd.OutputTo acOutputForm, "yourform", acFormatPDF, CurrentProject.Path & "\" & Format(Date, "dd-MM-yyyy ") & ".pdf", False تضع الكود السابق تحت زر امر على النموذج .. ستجد انه قام بحفظ الفورم بصيغة pdf في نفس مسار البرنامج لديك ملاحظة: اذا اردت ان يفتح الملف بعد الحفظ غير false الى true كما بامكانك تصدير الفورم يدوياً كما في الصورة تحياتي

بما انك لم ترفع ملف نمودج عما تريد اليك هاذا الشيء ربما تستفيذ منه listC.xlsm

تفضل لك ما طلبت تم وضع كود الأستاذ ابراهيم داخل الملف ... وعمل دالة معرفة لتحويل التاريخ الهجرى الى ميلادى بعمود اخر فليس هناك طريقة أو كود أخر لتحويل التاريخ على نفس العمود , أتمنى ان ينال إعجابك Private Function dateGregorian(sDate As String) As String Dim vVal As Variant Dim dtHijiri As Date VBA.Calendar = vbCalHijri If sDate <> vbNullString Then On Error GoTo XIT dtHijiri = DateValue(sDate) + 1 VBA.Calendar = vbCalGreg dateGregorian = dtHijiri End If Exit Function XIT: dateGregorian = vbNullString End Function export 1.xlsm

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

شكراً أخي حسين مامون هذا هو الذي أريده فعلا ... جزاك الله خير

انتبه من فضلك فالبحث يعمل بكل كفاءة كما ترى فقط عليك كتابة ما تريد بالبحث ثم فتح سهم القائمة فسترى ما يسرك ان شاء الله المعادلات كما أخبرك الأستاذ ابراهيم موجودة بـــ Sheet3 وأعتقد ان الإكسيل لديك أقل من 2010 ... يجب عليك تحديث الإكسيل فالملف يعمل بكل كفاءة عن تجربة كما أثبتلك سلفاً

تفضل -يمكنك استخدام هذه المعادلة مع ضبط تنسيق الخلايا =INT(E6/100)/24+MOD(E6,100)/1440 وهناك أيضاً معادلة ثانية ولكن طويلة =IF(LEN($E6)=3,LEFT(E6,1)&":"&RIGHT(E6,2),LEFT(E6,2)&":"&RIGHT(E6,2)) &" " & TEXT(IF(LEN($E6)=3,LEFT(E6,1)&":"&RIGHT(E6,2),LEFT(E6,2)&":"&RIGHT(E6,2)),"am/pm") وهذه معادلة ثالثة مع ضبط التنسيق أيضاً =--TEXT(E6,"00\:00") export - 1.xls

أشكرك جزيل الشكر أخي @أحمد يوسف تمت التجربة بنجاح و أشكركم جميعا مرة أخرى : @ابراهيم الحداد ، @ابو تيم تم تجربة الملفات و كلها ناجحة دعواتي لكم بالخير و الصحة و العافية لكم و لمن تحبون ..

جرب هذا الكود تحتار من الى من حلال الخلايا L2 و K2 تم تضغط الزر Run الصفحة (My_shee لاختيار اسم واحد تضع الخلايا L2 و K2 متساوتين مثلا من 10 الى 10 تعطيك السجل رقم 10 Sub Get_Dta() Dim M As Worksheet, T As Worksheet Dim LrM%, i%, Mn, Mx, k% Set M = Main: Set T = Targ LrM = M.Cells(Rows.Count, 1).End(3).Row T.Range("A2").Resize(LrM, 8).ClearContents If Val(T.Cells(2, "L")) < 2 _ Or T.Cells(2, "L") > LrM Then T.Cells(2, "L") = 2 If Val(T.Cells(2, "K")) < 2 _ Or T.Cells(2, "K") > LrM Then T.Cells(2, "K") = T.Cells(2, "L") + 10 Mn = Application.Min(T.Cells(2, "K"), T.Cells(2, "L")) Mx = Application.Max(T.Cells(2, "K"), T.Cells(2, "L")) T.Cells(2, "K") = Mx T.Cells(2, "L") = Mn T.Cells(2, 2).Resize(Mx - Mn + 1, 7).Value = _ M.Cells(Mn, 1).Resize(Mx - Mn + 1, 7).Value '+++++++++++++++By Choise++++++++++++++++++++++++ ' T.Cells(2, 1).Resize(Mx - Mn + 1).Value = _ ' Evaluate("Row(1:" & Mx - Mn + 1 & ")") T.Cells(2, 1).Resize(Mx - Mn + 1).Value = _ Evaluate("Row(" & Mn & ":" & Mx & ")") '+++++++++++++++++++++++++++++++++++++++++++++++++ End Sub الملف مرفق scorpionehb.xlsm

وجة (1).xlsm

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

اية.xlsm وجة.xlsm

اخي الفاضل بدون الحاجة الى ماكرو ممكن انك تلصق الداتا الجديدة في شيت ثاني وتطبق المعادلات في العمودين D و J تفضل اخي إضافة قيم لعمود.xlsm

لقد اقترحت على السائل هذا الأمر في اجابتي الثانية مع وضع الحل المناسب لكنه رفض ذلك

اخي الكريم من الاسهل ان ترتب الدفعات بشكل عمودي الرجاء الاطلاع على المرفق ارجو ان يلبي طلبك الغاية هي البساطة والسهولة وعدم التعقيد وللجميع الشكر والتقدير العملاء.xlsx

السلام عليكم ورخمة الله تم استخدام Sheet3 كورقة مساعدة يمكنك اخفاءها اذا اردت و قد تركت ظاهرة ليمكنك التعديل عليها اليك الملف كشف بأسماء العاملين بالوحدة.xlsx

حرب هذا الماكرو (تم ادراج اسماء الصفحات (Code Name اي الأسماء البرمجية) باللغة الأجنبية لعدم ظهور احرف غريبة و غير مفهومة في الكود مما يسهل عملية تسخه ولصقه من جهة و من جهة ثانية لا أحب الكتابة باللغة العربية داخل اي الكود) Option Explicit '++++++++++++++++++++++++++++++++++++ Dim sh As Worksheet Dim LastRow%, ro%, i%, m%, Last% Dim someRange As Range Dim My_Area As Range Dim Signle_cel As Range Dim adr1$, adr2$ Dim Ar(), itm '+++++++++++++++++++++++++++++++++++++ Sub Get_Sheet_name() Dim curt_rg As Range Set curt_rg = Main.Range("A2").CurrentRegion Last = curt_rg.Rows.Count If Last > 1 Then curt_rg.Offset(1).Resize(Last - 1).ClearContents End If i = 0 For Each sh In Sheets If sh.Name <> Main.Name Then Main.Range("A3").Offset(i) = sh.Name ReDim Preserve Ar(i) Ar(i) = sh.Name i = i + 1 End If Next End Sub '+++++++++++++++++++++++++++++++++++++++ Sub lasl_cell() Get_Sheet_name m = 3 For Each itm In Ar adr1 = "": adr2 = "" Set sh = Sheets(itm) ro = sh.Cells(Rows.Count, 1).End(3).Row sh.Range("A3").Resize(ro - 1, 9) _ .Interior.ColorIndex = xlNone Set someRange = Union(sh.Range("A2:A" & ro), _ sh.Range("D2:D" & ro), sh.Range("G2:G" & ro)) For Each My_Area In someRange.Areas For Each Signle_cel In My_Area.Cells If Signle_cel = "" Then GoTo Put_It adr1 = Signle_cel.Address adr2 = Signle_cel.Offset(, 2).Address Next Signle_cel Next My_Area Put_It: If adr1 <> "" And adr2 <> "" Then sh.Range(adr1).Resize(, 3). _ Interior.ColorIndex = 35 With Main.Cells(m, 2) .Value = sh.Range(adr1) .Offset(, 1) = sh.Range(adr2) End With End If m = m + 1 Next itm End Sub OUMALA3_New.xlsm

اذا كانت التواريخ مرتبة تنازليا لا يتناسب اخر تاريخ(Max) مع اخر دفعة

بهذه الطريقة صجيج انك تحصل على اكبر تاريخ لكن !!!! 1- ربما كانت التواريخ في مرتبة تصاعدياً (عتدها لا تكون اخر دفعة) 2- كيف تجد في اي عامود موجود هذا التاريخ؟؟؟؟

لحل هذه المشكلة يجب ان تكون البيانات المطلوبة في عامود واحد (كما في الملف المرفق) و الا لا حل الا بواسطة الـــ VBA OUMALA3_1.xlsx

جرب هذا الملف OUMALA3.xlsx

Sub OECUE1() Sheets("haneen").Activate Range("H2").Activate ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Do ActiveCell = ActiveCell + 1 ActiveWindow.SelectedSheets.PrintOut Loop While ActiveCell.Value <= Range("x2").Value Range("H2").Activate End Sub هكذا

تغيير بسيط Range("H2").Activate '[H2] = 1 End Sub او احذف جميع [H2]=1 قبل End Sub

السلام عليكم ورحمة الله وبركاته اخي كيف الاحوال هل يمكنك استخدام هذه الأكواد عمليا؟؟ جزيت خيرا وبارك الله فيك

الاذونات اعلاه اذا كان التطبيق على شبكة داخلية لكن اذا اردت ان تنشئ صلاحيات بنفسك فهو افضل لك و يتم وضع الصلاحيات في الحدث عند الفتح صلاحيات الاضافة تمكين المستخدم من الاضافة Me.AllowAdditions = True عدم تمكين المستخدم من الاضافة Me.AllowAdditions = False صلاحيات الحذف تمكين المستخدم من الحذف Me.AllowDeletions = True عدم تمكين المستخدم من الحذف Me.AllowDeletions = False صلاحيات التعديل تمكين المستخدم من التعديل Me.AllowEdits = True عدم تمكين المستخدم من التعديل Me.AllowEdits = False