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

تفضل أ.أيمن المطلوب بالمرفق المصنف1.rar

أخى الكريم ياسر بارك الله فيك وجازاكم خيرا طورت الكود بحيث يتم إنشاء مصنف لكل توجيه ويستثنى "بدون توجيه" ، كما يستثنى "بدون توجيه" في مصنف "قوائم التوجهات الكلية" ويصبح الكود بهذا الشكل : Sub MOKHTARTSET2() Dim myDir As String, C As Range, WB As Workbook, NWB As Workbook, Rng1 As Range, Rng2 As Range Set WB = ThisWorkbook myDir = ActiveWorkbook.Path & "\" & "My Workbook" Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next MkDir myDir On Error GoTo 0 '--------------------------------------------------------------------------------- WB.Sheets("Final").Select Range("D7:S7").Select Selection.AutoFilter ActiveSheet.Range("$D$7:$S$27").AutoFilter Field:=16, Criteria1:="<>بدون توجيه", Operator:=xlAnd Columns("F:Q").Select Selection.EntireColumn.Hidden = True Set Rng1 = WB.Sheets("Final").Range("d7:s27").SpecialCells(xlCellTypeVisible) Rng1.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D24").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Font.Bold = True .Interior.ColorIndex = 38 .Borders.LineStyle = xlContinuous End With ActiveSheet.Range("B2") = "قـــــوائم التوجهـــــــات الكلـــــية " NWB.SaveAs Filename:=myDir & "\" & "قـــــوائم التوجهـــــــات الكلـــــية " & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Selection.AutoFilter Range("X11").Select '-------------------------------------------------------------------------------------- For Each C In Sheets("Final").Range("U12:U23") WB.Sheets("Final").Range("AA1").Value = C.Value ' ------------------------------------------------------------------------------- WB.Sheets("Final").Activate Range("D7:S7").Select Selection.AutoFilter ActiveSheet.Range("$S$11:$S$27").AutoFilter Field:=16, Criteria1:="<>بدون توجيه", Criteria2:="=" & C.Value, Operator:=xlAnd Range("F:Q,S:S").Select Selection.EntireColumn.Hidden = True Set Rng2 = WB.Sheets("Final").Range("D7:R27").SpecialCells(xlCellTypeVisible) Rng2.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D10").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Font.Bold = True .Borders.LineStyle = xlContinuous .Interior.ColorIndex = 38 End With ActiveSheet.Range("B2") = "الموجهون الى" ActiveSheet.Range("C2") = C.Value NWB.SaveAs Filename:=myDir & "\" & C.Value & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Selection.AutoFilter Range("A1").Select '----------------------------------------------------------------------------------- Next C Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub أشكرك أستاذى العزيز . Pupils Distribution According To Marks & Wishees by mokhtar v2 .rar

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

بارك الله فيك أخي الحبيب الغالي مختار زيادة في الخير وإثراءً للموضوع إليك الحل التالي ..حيث يتم إنشاء مصنف لكل توجيه ويستثنى "بدون توجيه" ، كما يستثنى "بدون توجيه" في مصنف "قوائم التوجهات الكلية" يتم إنشاء مجلد في نفس مسار المصنف الحالي باسم Results يتم تصدير المصنفات به Sub YasserKhalil() Dim rngData As Range, rngToCopy As Range, arrFilter, I As Long, J As Long Application.DisplayAlerts = False Application.ScreenUpdating = False If Len(Dir(ThisWorkbook.Path & "\Results", vbDirectory)) = 0 Then MkDir ThisWorkbook.Path & "\Results" End If Set rngData = Range("D7:S" & Cells(Rows.Count, "D").End(xlUp).Row) arrFilter = Application.Transpose(Range("U12:U" & Cells(Rows.Count, "U").End(xlUp).Row)) ReDim Preserve arrFilter(1 To UBound(arrFilter) + 1) arrFilter(UBound(arrFilter)) = "<>بدون توجيه" For I = 1 To UBound(arrFilter) ActiveSheet.AutoFilterMode = False rngData.AutoFilter Field:=16, Criteria1:=arrFilter(I) J = rngData.Columns(1).SpecialCells(xlCellTypeVisible).Count If J = 1 Then GoTo skipper Set rngToCopy = Intersect(Union(Columns("D:E"), Columns("R:S")), rngData.SpecialCells(xlCellTypeVisible)) Workbooks.Add ActiveSheet.Cells.Clear rngToCopy.Copy Range("B5") With Range("B2:E3") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .MergeCells = True .Font.Size = 20 .Value = IIf(I < UBound(arrFilter), arrFilter(I), "قوائم التوجهات الكلية") End With If I < UBound(arrFilter) Then Columns("E").Delete ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & arrFilter(I) & ".xlsx" Else ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Results\" & "قوائم التوجهات الكلية" & ".xlsx" End If ActiveWorkbook.Close skipper: Next I ActiveSheet.AutoFilterMode = False Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub تقبل تحياتي Export Workbooks Using Filter Method.rar

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

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

هو ايه اللي يجري بالمشاركات يطلبون كود و لما تضعه يطلبون معادلة و العكس بالعكس

أخي الكريم يرجى تغيير اسم الظهور للغة العربية ويرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لكيفية التعامل مع المنتدى بشكل جيد إليك الكود التالي عله يفي بالغرض Sub TestRun() Dim SHP As Shape, strX As String Dim lColLeft As Long, lColRight As Long Dim LR As Long Application.ScreenUpdating = False With Sheet1.Shapes(Application.Caller) If Mid(.Name, 1, 9) = "Rectangle" Then strX = Mid(.TextFrame.Characters.Text, InStr(.TextFrame.Characters.Text, ": ") + 2) lColLeft = .TopLeftCell.Column: lColRight = .BottomRightCell.Column With Sheet2 LR = .Cells(Rows.Count, 1).End(xlUp).Row + 1 .Range("A" & LR).Value = strX .Range("B" & LR).Value = Sheet1.Cells(2, lColRight).Value .Range("C" & LR).Value = Sheet1.Cells(2, lColLeft).Value End With End If End With Application.ScreenUpdating = True End Sub يتم ربط الشكل بالكود عن طريق كليك يمين ثم Assign Macro ثم اختيار اسم الماكرو TestRun لا تنسى أن تحدد أفضل إجابة إذا أعجبتك المشاركة كما لا تنسى أن تضغط كلمة "أعجبني هذا" إذا أعجبك المحتوى تقبل تحياتي وتوجيهاتي Application Caller & Shapes YasserKhalil.rar

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

أخي الحبيب أبو حنين توضع الأكواد بين أقواس الكود والتي تكون بهذا الشكل من خلال محرر الكتابة <> ابحث عن هذا الشكل جرب الكود التالي ..لم أجرب الكود Sub PDF_SALAM() Dim MyName As String MyName = "D:\MANAFIST TAREK\PDF\MANAFIST TAREK TO SALAM_" & Format(Date + 1, "dd-mm-yyyy") & ".pdf" Range("C45").Select Range("C45").Select Sheets(Array("زراعى", "صحراوى", "طائرة")).Select Sheets("طائرة").Activate If MsgBox("هل تريد إرسال الملف المرفق إيميل أم لا؟", vbYesNo, "Send Email") = vbNo Then GoTo 1 OutlMail_PDF MyName, "Mohamed.Tawfek@khalda-eg.com;Mohamed.Amria@khalda-eg.com;mohamed.abonour@khalda-eg.com", "مانفست حقول طارق", _ vbNewLine & "مع تحيات ..إدارة الشئون الادارية بحقول طارق", False 1 MyMsg = MsgBox("هل انت متاكد من اتمام عمليه الحفظ", 4, "تنبيه") If MyMsg = 6 Then ChDir "D:\MANAFIST TAREK" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ MyName, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False Else MsgBox "لم يتم الحفظ" End If Sheets("طائرة").Select ActiveWindow.SmallScroll Down:=-12 Range("B5").Select End Sub Function OutlMail_PDF(FileNamePDF As String, StrTo As String, StrSubject As String, StrBody As String, Send As Boolean) Dim OutApp As Object Dim OutMail As Object Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = StrTo .CC = "" .BCC = "" .Subject = StrSubject .Body = StrBody .Attachments.Add FileNamePDF If Send = True Then .Send Else .Display End If End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing End Function شوف أنا وضعت الكود بين أقواس تنصيص عملت كليك على العلامة <> ثم لصقت الكود بداخله (ولكن يراعى عند نسخ الكود أن يكون اتجاه الكتابة باللغة العربية حتى لا تظهر اللغة العربية بحروف غريبة) تقبل تحياتي

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

تفضل اخي هذا المطلوب اضغط افضل اجابة ليكون الموضوع منتهَ find1.zip

اخى الكريم ممكن تستخدم برنامج Smart Install Maker وده شرحه لأختنا الكريمه زهره والبرنامج والسريال بالمرفقات بالتوفيق إن شاء الله شرح.rar smart install maker 5.04.zip

السلام عليكم ورحمة الله وبركاته أستأذن أخى وأستاذى العزيز ياسر خليل وأشارككم بهذه المحاولة التى أعتبرها بداية جيدة أتفق مع رأى أستاذى العزيز ياسر الأخير بالمشاركة 9 حيث يتم تصدير كل توجيه الى مصنف مستقل ويتم تصدير كل التوجيهات الى مصنف عام يجمع الكل فهو الأيسر والأسهل والأقرب الى الصواب فبدلا من أن يكون هناك زر أمر لكل توجيه على حدا وأكواد متعددة يكفى زر واحد وكود واحد يقوم بذلك : الكود : Sub MOKHTARTSET() Dim myDir As String, C As Range, WB As Workbook, NWB As Workbook, Rng1 As Range, Rng2 As Range Set WB = ThisWorkbook myDir = ActiveWorkbook.Path & "\" & "My Workbook" Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next MkDir myDir On Error GoTo 0 '--------------------------------------------------------------------------------- WB.Sheets("Final").Select Columns("F:Q").Select Selection.EntireColumn.Hidden = True Set Rng1 = WB.Sheets("Final").Range("d7:s27").SpecialCells(xlCellTypeVisible) Rng1.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D24").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Borders.LineStyle = xlContinuous End With ActiveSheet.Range("B2") = "قـــــوائم التوجهـــــــات الكلـــــية " NWB.SaveAs Filename:=myDir & "\" & "قـــــوائم التوجهـــــــات الكلـــــية " & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Range("X11").Select '-------------------------------------------------------------------------------------- For Each C In Sheets("Final").Range("U12:U23") WB.Sheets("Final").Range("AA1").Value = C.Value ' ------------------------------------------------------------------------------- WB.Sheets("Final").Activate Range("D7:S7").Select Selection.AutoFilter ActiveSheet.Range("$D$7:$S$27").AutoFilter Field:=16, Criteria1:="=" & C.Value, Operator:=xlAnd Range("F:Q,S:S").Select Selection.EntireColumn.Hidden = True Set Rng2 = WB.Sheets("Final").Range("D7:R27").SpecialCells(xlCellTypeVisible) Rng2.Select Selection.Copy Set NWB = Workbooks.Add ActiveSheet.Range("A4").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Range("A4:D10").Select With Selection .HorizontalAlignment = xlCenter .Font.Size = 10 .Borders.LineStyle = xlContinuous End With ActiveSheet.Range("B2") = "الموجهون الى" ActiveSheet.Range("C2") = C.Value NWB.SaveAs Filename:=myDir & "\" & C.Value & ".xlsx", CreateBackup:=False NWB.Close WB.Activate WB.Sheets("Final").Cells.Select Selection.EntireColumn.Hidden = False Selection.AutoFilter Range("A1").Select '----------------------------------------------------------------------------------- Next C Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub الكود ينتج عنه الملفات المطلوبة داخل مجلد باسم My Workbook فى مسار الملف أرجو أن يكون هو المطلوب. Pupils Distribution According To Marks & Wishees by mokhtar .rar

لدي عدد من الملفات في لاكسل وارغب عملها مع محترف اكسل بشروط 1- ان يكون العمل بمقابل مادى 2- ان يكون العمل بمقابل مادى 3- ان يكون العمل بمقابل مادى 4- لاارغب العمل بالمجان نهااااااااااااائي يعني بزنس ( ...) قد يقول احدكم اطرح موضوعك والجميع يساهم في حله . مجاني ..( هذا الكلام لا يصلح لان العمل خاص اولا وثانيا عندما يكون العمل مجاني فانني احتمال انتظر اسبوع او شهر او اكثر لاجل حله ) وانا ارغب انجازه باسرع وقت انا ارغب عمل مقابل دفع مادة للعمل ....... ارغب انجازه بسرعة ارجو من لديه القدره على العمل التواصل عبر الخاص مشكوووووورين

وهذا للفائدة .. ممكن يوضع داخل البرنامج ولا يصل له بطريقة أو بأخرى الا مصمم البرنامج ... مثلا يوضع في نموذج ويضاف زر امر وفي حدث عند النقر يوضع الكود التالي : Dim prop As Property On Error GoTo SetProperty Set prop = CurrentDb.CreateProperty("AllowBypassKey", dbBoolean, False) CurrentDb.Properties.Append prop SetProperty: If MsgBox("هل ترغب بتفعيل مفتاح الشفت ؟", vbYesNo, "تفعيل عمل الشفت") = vbYes Then CurrentDb.Properties("AllowBypassKey") = True Else CurrentDb.Properties("AllowBypassKey") = False End If بالتوفيق ..

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

أخي الكريم خالد هلال إليك الملف التالي عله يفي بالغرض Sub Tarhil() Dim WS As Worksheet, SH As Worksheet Dim LR As Long Set WS = Sheets("الإيصال"): Set SH = Sheets("اليومية") LR = SH.Cells(Rows.Count, 6).End(xlUp).Row + 1 Application.ScreenUpdating = False With SH .Range("A" & LR) = LR - 4 .Range("B" & LR) = WS.Range("G3") .Range("C" & LR) = WS.Range("G2") .Range("D" & LR) = WS.Range("B4") .Range("E" & LR) = WS.Range("B5") .Range("F" & LR) = (WS.Range("B6") - Int(WS.Range("B6"))) * 100 .Range("G" & LR) = Int(WS.Range("B6")) .Range("H" & LR) = WS.Range("D5") .Range("I" & LR) = WS.Range("B7") WS.Range("G3") = WS.Range("G3") + 1 End With MsgBox "تم الترحيل بنجاح", vbInformation Application.ScreenUpdating = True End Sub لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي كما لا تنسى أن تضغط أعجبني هذا إذا أعجبتك المشاركة وأدت الغرض تقبل تحياتي Tarhil YasserKhalil.rar

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

السادة إخوانى وأعزائى أعضاء وأساتذة المنتدى العظيم مرفق ملف إكسيل به جميع إختصارات الإكسيل وإختصارات أخرى أرجوا من الله العلى القدير أن ينال رضاكم تقبلوا خالص تحياتى Short Cut Excel.rar

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

برنامج الشفت يعمل عندي بشكل سليم ويوجد برامج مشابه لهذا البرنامج يمكنك البحث عنها بالمنتدى المرفق الثاني موجود في برامج لي ويعمل تمام ماعدى النقطه الي تكلمتي عنها صحيح ظهر لي نفس المشكله في زر " إظهار_مع_عدم_إظهارها_بالخيارات " تحياتي

السلام عليكم اخى الحبيب ابوالــبراء اسف على هذا السهو الغــير مقصود والله الاستاذ خالد رشدي له منا كل تقدير واحــترام ولكن لي عندك رجاء تعديل كود مسح البيانات دون المعادلات الخاص بحضرتك ليعمل على اكثر من عمودين تقبل تجياتي

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

السلا م عليكم اخى الحبيب ياسر خليل اولا وقبل اى شئ كل عام وانت وجميع المسلمين بكل خير تقبل الله من صيامك وقيامك ثانيا اخى الحبيب تم ارفاق الملف ثالثا لا اعلم كيف اضع الكود بين اقواص التنصيص ... ارجو التوضيح جزاك الله كل الخير mail & pdf.rar

ها هى طريقة بدون عمود مساعد لعل ذلك هو المطلوب جرب المرفق نموزج.rar ........................... هذه معادلة صفيف بعد كتابتها لا يتم الضغط على انتر وإنما Ctrl+Shift+Enter

أخي الكريم أيمن إبراهيم شوف مشاركة الأخ الفاضل خالد الرشيدي رقم 2 وشوف مشاركتك رقم 3 ركز على الجزء اللي فيه كلمة "أعجبني هذا" هتلاقي إنك معملتش إعجاب للأخ الحبيب خالد مع إنه يستاهل ، وهو عمل إعجاب على ردك اللي بتشكره فيه (عجبت لك يا أستاذنا أيمن ... متفوتش عليك دي) تقبلوا وافر تقديري واحترامي

اخى الفاضـــل خالد الرشــــيدى اشــــكرك على سرعة استجابتك تقبل تحياتي وكل عام وانتم بخـــير

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

ممتاز أخى الكريم هل لى من طلب ؟ أن تبدأ موضوعك بالسلام ، هذا يجعل قلبى مطمئنا بأن الدنيا مازالت بخير بذكر الله أرجو ان لا أكون مثقلا عليك فى طلبى .. دامت محبتك فى القلوب دمت بخير و أعزك الله

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

و عليكم السلام و رحمة الله و بركاته أخى الكريم أقدم لك حلا قد لا يعجبك لإستعانتى بعمود أضافى و إظهار النتائج فى العمود C و ليس B حاولت كثيرا تجنب العمود الاضافى بلا جدوى و سأفكر فى صيغة أخرى إن شاء الله عموما إن أحببت الاطلاع على الحل ستجده بالمرفق .. و فضلا لا أمرا أخى الكريم يرجى الاطلاع على موضوع توجيهات الاعضاء الجدد من هنا http://www.officena.net/ib/index.php?showtopic=60147 و يرجى تغيير إسم الظهور الى اللغة العربية .. و معذرة لعدم قدرتى تنفيذ الحل على النحو المطلوب و تحية طيبة لأستاذى سليم حاصبيا و لحله المبدع دمتم بخير و أعزكم الله . move.rar

ربما لم أفهم المطلوب بشكل جيد قمت بعمل دالة معرفة تتعامل مع كل زاوية .. إذا كانت الزاوية أقل من 180 يتم إضافة 360 لها وهكذا ثم يتم عد الزوايا وحساب المتوسط على حسب العدد أرجو أن يكون المطلوب .. Function AnglesAverage(Rng As Range) Dim Cell As Range, Counter As Long, Temp For Each Cell In Rng If Cell.Value < 180 And Not IsEmpty(Cell) Then Temp = Temp + Cell.Value + 360 Else Temp = Temp + Cell.Value End If If Not IsEmpty(Cell) Then Counter = Counter + 1 Next Cell AnglesAverage = Temp / Counter End Function تقبل تحياتي Angles Average UDF Function.rar

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

هلا بك ام خلود يوجد مرفقين الاول برنامج خاص بتمكين والغاء الشفت المرفق الثاني يوجد به 1- نموذج FORM وهو اخفاء الجداول المرتبطه او غير مرتبطه وايضاً النماذج والاستعلامات الى اخ وعليه رقم سري 123 والفائده منه بعد ماتخلصين من البرنامج تخفين جميع الكائنات وتضعين لك رقم سري ولاتنسين اغلاق الاكواد برقم سري 2- يوجد في نموذج FM_1 كود في الحالي ونا دايم احطه في نموذج اسم المستخدم وكلمه المرور وايضا في النموذج الرئيسي للبرنامج والفائده منه اخفاء قوائم الاكسس ملاحظه لإظهار القوائم قومي بتعليق الكود ثم اقفلي البرنامج وفتحيه مره اخرى ايضاً يوجد كود لإظهار رقم الهارد دسك اول مايفتح الشاشه الرئيسيه راح تلاقين رقم القرص انسخيه وروح للكود موجود في النموذج عند الفتح وضعيه مكان رقم -829258002 ثم الغي تعليق الاكواد الغرض منه عند نقل البرنامج لجهاز اخر لن يعمل وفي الاخير اعملي رقم سري على الاكواد حتى لايستطيع احد الدخول لها هذي من بعض حمايتي المتواضعه لبرامجي ويوجد حمايات اخرى اضعها في برامجي وهذا ما استفدناه من اساتذتنا في هذا الصرح الشامخ ولديهم الكثير ولن يبخلو عليك في المساعده اتمنى ان اكون افدتك خاص بنظام الشفت.rar SA.rar

ماشاء الله الاخ الصقر ... صقر فعلا تحياتى الاخ علاء رسلان .. تحياتى ..واذا امكن ان تشرح لنا طريقتك التى توصلت بها ليستفيد الجميع اذا احببت متابعتى على الفيس بوك هذا رابط الموضوع https://www.facebook...&type=1

أخي الكريم أشرف إليك الملف التالي فيه 90% مما طلبت أما بالنسبة للتلوين لا أرى داعي لها حيث أن كل توجيه في مصنف مستقل الآن .. قمت بحذف جميع التنسيقات الموجودة في المصنفات المصدرة جرب الملف التالي وأعلمنا بالنتيجة Export Workbooks Using Filter Method.rar

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

الله الله عليك يا أبا البراء رائع هذا الكود رغم أن فيه شوية كلاكيع استفسار : ليه تم استثناء مصنف لــ "بدون توجيه" ، كما تم استثناء "بدون توجيه" في مصنف "قوائم التوجهات الكلية" مع أن من المفروض أن يعامل غير الموجهين كغيرهم فهم جزء من الكل ولا ده طلب لأخونا أشرف .دى نقطة النقطة الثانية فى ملف أخونا أشرف وضع أسماء التوجهات النهائية فى النطاق "U12:U23" وفيهم التوجه التسويق 3 مع أنه مش موجود فى العمود S وأنا فى كودى اعتمدت على هذا النطاق لعمل مصنف لكل توجه موجود بهذا النطاق وبالتالى فى مخرجات كودى طلع مصنف التسويق 3 فارغ بدون أسماء ليه ؟؟؟؟؟؟؟؟؟؟؟؟؟ لأن أصلا مفيش حد تم توجيهه الى التسويق 3 وأخوك ضليع جدا فى المعادلات وعايز معادلة فى النطاق "U12:U23" تاخذ من العمود S أسماء التوجهات النهائية بدون تكرار وتستثنى بدون توجيه وبكده لا يظهر فى مخرجات كودى أى مصنف فارغ ياريت أكون واضح فى طلبى تحياتى لك

السلام عليكم و رحمة الله و بركاته محاولة بسيطة مأخوذة من منتدانا الغالي أوفيسنا ربما تفي بالغرض الشكر موصول لصاحبها تحويل التاريخ الهجري و الميلادي.rar

تفضل رابط جديد http://www.officena.net/ib/?showtopic=42659

اخى الحبيب بعد تفكير سريع افضل العرض الثانى سيحقق لى ربح بعد 3 سنوات يصل الى 10350 27000 +10350(ربح) = 37350 ( اعتقد هذا افضل العروض تقبل تحياتى

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

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

برجاء التوضيح ما هي الشروط التى تقصدها، وعلى أى أساس يتم تحديد الرغبات للاسم؟؟

البرنامج أكسيس 2010 تنسيق 2003 اسم المستخدم 1 السري 1

أخي الكريم اللامع أهلاً بك في المنتدى ونورت بين إخوانك يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة في المنتدى لتعرف كيفية التعامل مع المنتدى بشكل جيد كما يرجى تغيير اسم الظهور للغة العربية وستجد التفاصيل Details في رابط التوجيهات يمكن التحايل في المعادلة الموجودة في الخلية C5 لتصبح بهذا الشكل =WriteNo(INT(C4),0,"دينار") & " و"&" ( " & INT(MOD(C4,1)*1000) & " ) " & "درهم " تقبل تحياتي

على رسلك أخي الحبيب علاء رسلان فربما لم يمر الأمر بك أو أن الأمر حديث عهد بالرياضيات عموماً ضع الزاوية الأولى في الخلية A1 والزاوية الثانية في الخلية B1 ثم جرب في الخلية C1 المعادلة التالية علها تفي بالغرض =IF(SIN(A1-B1)>0,(A1+B1)/2,(A1+B1+360)/2) يا عاشق الرياضيات .. لك قرين يعشق الرياضيات (اللي هو العبد لله) بس طبعاً مستوايا لا يرقى أبداً إلى مستواك تقبل تحياتي وحبي واحترامي

الاخ العزيز الاستاذ الفاضل // محمد الريفى السلام عليكم هناك أحد الزملاء الافاضل أسمه نادر أما عن حامى فيقصد الاخ السائل أن هناك حماية للمعادلات اما دون ذلك فندعو الاخ السائل بتغير اسمه للعربية لتواصل أفضل وافر احترامى

السلام عليكم جرب الكود التالي Sub kh_trheel() Dim Sht1 As Worksheet, Sht2 As Worksheet, Shp1 As Worksheet, Shp2 As Worksheet Dim Lr As Long, R As Long Dim t1 As String, t2 As String Set Sht1 = Sheets("البيانات الرئيسية") Set Sht2 = Sheets("البيانات الفرعية") Set Shp1 = Sheets("مشمول") Set Shp2 = Sheets("غير مشمول") With Shp1.Range("A2:E2") Range(.Cells, .Cells.End(xlDown)).ClearContents End With With Shp2.Range("A2:E2") Range(.Cells, .Cells.End(xlDown)).ClearContents End With Lr = Sht1.Range("A" & Rows.Count).End(xlUp).Row For R = 2 To Lr t1 = CStr(Sht1.Cells(R, "B")) & CStr(Sht1.Cells(R, "C")) & CStr(Sht1.Cells(R, "D")) & CStr(Sht1.Cells(R, "E")) t2 = CStr(Sht2.Cells(R, "B")) & CStr(Sht2.Cells(R, "C")) & CStr(Sht2.Cells(R, "D")) & CStr(Sht2.Cells(R, "E")) If t1 = t2 Then Shp1.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 5).Value = _ Sht1.Cells(R, "A").Resize(1, 5).Value Else Shp2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 5).Value = _ Sht2.Cells(R, "A").Resize(1, 5).Value End If Next Set Sht1 = Nothing: Set Sht2 = Nothing: Set Shp1 = Nothing: Set Shp2 = Nothing End Sub المرفق 2003 ترحيل بيانات.rar تحياتي