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

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

السلام عليكم ورحمة الله وبركاته إخواني وأحبابي في الله بدايةً من هذا الموضوع لن أقوم بإرفاق ملفات في الموضوع وسأترك لكم التطبيق العملي بأنفسكم (حتى نتطور) ... كفانا ملفات مرفقة جاهزة فرأيي أن الملفات المرفقة الجاهزة تبعث على الكسل بشكل كبير .. كل ما يقوم به العضو هو تحميل الملف المرفق ثم تجربته ولو تيسر له الأمر قليلاً لألقى نظرة على العمل وعلى الأكواد الموجودة ..وقلما تجد من يدرس الملف المرفق بهدف التعلم من ثم .. فهذا الموضوع موجه لمن يريد ويرغب بالتعلم وليس لمن يريد الملفات الجاهزة .. سأقوم إن شاء ربي بسرد الخطوات ببساطة شديدة يفهمها الجميع (المبتديء قبل المحترف) نبدأ على بركة الله افتح ملف إكسيل جديد (خطوة صعبة بس أنا عارف إن 90% هيقدر على الخطوة دي ) احفظ الملف الجديد بامتداد xlsm أو Excel Macro-Enabled .. لمعرفة المزيد يمكنك الإطلاع على موضوع (بداية الطريق لإنقاذ الغريق) روح لمحرر الاكواد عن طريق Alt + F11 وأدرج موديول جديد من خلال القائمة Insert ثم الأمر Module الصق الكود التالي في الموديول #If VBA7 Then Public Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #Else Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #End If Sub PlayWavFile(WavFileName As String, Wait As Boolean) If Dir(WavFileName) = "" Then Exit Sub If Wait Then sndPlaySound WavFileName, 0 Else sndPlaySound WavFileName, 1 End If End Sub Sub PlaySoundNotesInExcel(CellAddress As String) Dim SoundFileName As String SoundFileName = "" On Error Resume Next SoundFileName = Range(CellAddress).Comment.Text On Error GoTo If SoundFileName = "" Then Exit Sub If InStr(1, SoundFileName, Chr(10)) > 0 Then SoundFileName = Left(SoundFileName, InStr(1, SoundFileName, Chr(10)) - 1) End If PlayWavFile SoundFileName, False End Sub هرفق ملف صوتي بامتداد WAV للتطبيق عليه .. الملف باسم TestWAV فك الضغط عن الملف المضغوط هتلافي اسم الملف TestWAV اعمل عليه كليك يمين ثم الأمر Properties أي خصائص روح للتبويب Security (بس اوعى بتوع الأمن يقفشوك) ..المهم هتلاقي سطر بهذا الشكل (مسار الملف الصوتي) C:\Users\Future\Desktop\TestWAV.wav دا هيكون شكل المسار للملف ..طبعاً هيختلف من جهاز لجهاز آخر .. المهم انسخ سطر المسار ده الخطوة التالية ..شوف أي خلية تريد أن يعمل الصوت عند تحديدها ليكن الخلية G7 (أصلي بحب رقم 7 والعمود G هو العمود السابع وفي نفس الوقت الصف السابع .. متدقش على كلامي) كليك يمين على الخلية (بزر الماوس الأيمن يا حاج أيمن .. شايف واحد بيبص على الماوس مفيش مشكلة المهم يعرف يطبق) اختر الأمر Insert Comment أي إدراج تعليق ، ممكن تلاقي كلام امسحه وخلي التعليق فاضي ، وأخيراً ضع المسار اللي نسخته من شوية عن طريق Ctrl + V أي لصق المنسوخ .. لحد هنا بس خلاص الخطوة التالية : روح اعمل كليك يمين على اسم ورقة العمل النشطة اللي فيها الخلية الهدف G7 المطلوب تشغيل الملف الصوتي عند تحديدها كليك يمين على اسم ورقة العمل ثم اختر الأمر View Code والصق الكود التالي في حدث ورقة العمل Private Sub Worksheet_SelectionChange(ByVal Target As Range) PlaySoundNotesInExcel (Target.Address) End Sub سؤال أخير . هل العمل سيكون على خلية واحدة فقط ؟؟ الإجابة : لا ..براحتك ...كل ما عليك بعد كدا لو عايز تشغل الملف الصوتي أو أي ملف صوتي آخر ..إنك تاخد المسار وتروح للخلية وتدرج تعليق وفي التعليق تضع مسار الملف الصوتي المراد تشغيله وبس خلاص أرجو أن يكون الشرح سهل وبسيط وسلس ... ويكون التطبيق فيه مشاكل (أيوا فيه مشاكل عشان يكون فيه استفسارات ونتعلم) دمتم على طاعة الله كان معكم أخوكم أبو البراء من منتدى أوفيسنا حمل الملف من هنا

ما شاء الله بارك الله بحر من العلم الزاخر بالدرر جزاكم الله خيراً. عمل رائع وإضافات جميلة.. لا نملك إلا تقديم الشكر.. والسلام عليكم.

السلام عليكم استاذتى الاعزاء اسمحوا لى ان ازيد فى هذا الخير بهذه المعادلة =VALUE(REPLACE(D2;FIND("٫";D2;1);1;".")) test.rar

خلاص بقي ياعم صقر وقت التحدي انتهى (وفهمتوا التيته ) ابقي ترجم التيته دي لاني معرفشي اقولها ازاي

أخي الحبيب عبد العزيز في انتظار التطبيق .. ويا ريت تطبق ع الجديد .. اللي هو عمله أخونا ياسر العربي أخي الحبيب الغالي ياسر العربي إضافة في قمة الروعة بالتأكيد .. كونك تجعل مسار الملف الصوتي في نفس مسار المصنف (ودا أمر مستحب بالنسبة لي) بس ممكن ييجي واحد رخم زي حالاتي بردو ويقولك لا أنا مش عايز الملف الصوتي في نفس مسار المصنف (رخامة بقا) عموماً إضافة جميلة وأنا أحبذها وأررجحها ودا التعديل الجديد للأخ ياسر العربي الكود بالكامل في الموديول #If VBA7 Then Public Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #Else Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long #End If Sub PlayWavFile(WavFileName As String, Wait As Boolean) If Dir(WavFileName) = "" Then Exit Sub If Wait Then sndPlaySound WavFileName, 0 Else sndPlaySound WavFileName, 1 End If End Sub Sub PlaySoundNotesInExcel(CellAddress As String) Dim SoundFileName As String, MyPath As String SoundFileName = "" On Error Resume Next MyPath = ThisWorkbook.Path & "\" SoundFileName = MyPath + Range(CellAddress).Comment.Text On Error GoTo 0 If SoundFileName = "" Then Exit Sub If InStr(1, SoundFileName, Chr(10)) > 0 Then SoundFileName = Left(SoundFileName, InStr(1, SoundFileName, Chr(10)) - 1) End If PlayWavFile SoundFileName, False End Sub تم إضافة سطر وتعديل سطر MyPath = ThisWorkbook.Path & "\" SoundFileName = MyPath + Range(CellAddress).Comment.Text بارك الله فيك أخي الغالي ياسر وفي انتظار المزيد من الرخامات المستحبة لي

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

جميل جداً اشكرا الجميع على جهودهم واشكر صاحب الكوضوع على التحدي الذي كان نتاجه هذه الحلول الجميلة وشكراً

السلام عليكم جرب الكود التالي Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean) Dim Shet As Worksheet Dim Do_Ali Dim Ar() As Variant Dim iCnt& Dim X, A Set Shet = Sheets("Report") Set Do_Ali = CreateObject("Scripting.Dictionary") With Application .ScreenUpdating = False .EnableEvents = True DoEvents With Shet Lr = .Cells(.Rows.Count, 2).End(xlUp).Row Ar = .Range("A2:F" & Lr).Value: A = Bl For R = LBound(Ar, 1) To UBound(Ar, 1) If Ar(R, 3) = A Then If Not Bln Then X = IIf(Vl = 3, X + 1, IIf(Vl = 4, X + Ar(R, 6), X + 1)) If Do_Ali.exists(Ar(R, Ln)) Then Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1 Else Do_Ali.Add Ar(R, Ln), 1 End If End If Next Ali = IIf(Vl = 1, Do_Ali.Count, X) End With .ScreenUpdating = True .EnableEvents = False End With Erase Ar Set Do_Ali = Nothing Set Shet = Nothing End Function Sub Ali_Count() Dim Sh As Worksheet Dim R Set Sh = Sheets("Rank") For R = 10 To 28 With Sh If .Cells(R, 2) <> "" Then .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False) .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False) .Cells(R, 14) = Ali(4, 1, .Cells(R, 2), True) .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True) End If End With Next Set Sh = Nothing End Sub

انا قبلت التحدي و اليك المعادلة اللازمة لهذا الشيء انسخها الى الخلية F2 واسحب نزولاً =SUBSTITUTE(TRIM(SUBSTITUTE(D2,CHAR(32),"")),"٫",".")*1+(SUBSTITUTE(TRIM(SUBSTITUTE(D2,CHAR(32),"")),"٫",".")*E2)

السّلام عليكم و رحمة الله و بركاته بارك الله فيكما : الأستاذ القدير "الصّقر" الأستاذ القدير "ياسر العربي" على الحلول العمليّة المفيدة و الرّافعة للتحدّي ..قبِلتما التحدّي و كسبتماه.. رغم إنّي من المتفرّجين لكن .. المتفرّجين المشجّعين الذين يجيدون التّصفيق بحرارة ..أقول لكما : بارك الله فيكما و زادكما من علمه وفضله و زادها بميزان حسناتكما فائق إحتراماتي

اخ ياسر العربي حل جميل وهذا لتغير الفاصله في مدى الارقام Sub A() Dim R As Range For Each R In Range("B2:D" & Cells(Rows.Count, 2).End(xlUp).Row) R.Replace [i1], "." Next End Sub

فنون وأساليب التنبؤ باستخدام الاكسيل السلام عليكم ورحمة الله وبركاته موضوع اليوم استخدام الدوال ذات الدالة الأسية ( الاتجاهات الغير خطية الأسية ) فى التوقع او التنبؤ واتناول فيه الدالة Growth بالطريقة الرياضية والبيانية استخدام طريقة التمهيد الأسى Exponential Smoothing فى التوقع باستخدام الطريقة الرياضية وادوات تحليل البيانات solver ___________________ارجو ان يفيد الجميع ________________________ تناولت فى الموضوع السابق استخدام الاتجاهات الخطية فى التنبؤ واستخدمت الدوال forecast و trend و slope و intercept وتناولنا الطرق الرياضية والبيانية رابط الموضوع السابق http://www.officena.net/ib/topic/64412-فنون-وأساليب-التنبؤ-باستخدام-الاكسيل/ الجزء الثانى .rar

زيادة في اثراء الموضوع هذا الملف كيلو جرام salim.zip show_names_1_2_by letters.zip يمكن ايضاً بكل بساطة استعمال هاتين المعادلتين =MOD(A3,1000) والثانية =QUOTIENT(A3,1000)

أخي الكريم وحيد في الخلية B2 ضع المعادلة التالية =MOD(A2/1000,1)*1000 ثم قم بسحبها وفي الخلية C2 ضع المعادلة التالية =INT(A2/1000) ثم قم بسحبها إذا صادفتك مشكلة بالمعادلة قم باستبدال الفاصلة العادية في المعادلة بفاصلة منقوطة .. تقبل تحياتي

أخي الحبيب علي العيدروس جزيت خير الجزاء على هذا الإبداع .. ولكن لي تعليق بسيط .. حجم البيانات بالملف كبير جداً مما يجعل التعامل مع البيانات باستخدام الحلقات التكرارية أمر مهلك للغاية في هذه الحالة أعتقد أنه من الأفضل استخدام المصفوفات .. لذا أقدم لك كود يقوم بالأمر (الكود ليس لي بالطبع .. لأنني ما زلت في بداية الطريق في التعامل مع المصفوفات) والكود سيكون أسرع في التعامل مع الملف بهذا الحجم الهائل من البيانات أخي الغالي ياسر جرب الكود التالي Sub Test() Dim Coll As New Collection, CollDummy1 As New Collection, CollDummy2 As New Collection Dim ArrData, ArrIn, ArrOut1(), ArrOut2(), ArrOut3(), ArrOut4(), ArrCalc(), ArrTemp Dim I As Long, P As Long With Sheets("Report") ArrData = .Range("A2:F" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 2)) End With With Sheets("Rank") ArrIn = .Range("B10:B" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 10)) End With ReDim ArrOut1(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut2(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut3(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrOut4(1 To UBound(ArrIn, 1), 1 To 1) ReDim ArrCalc(1 To UBound(ArrData, 1), 1 To 2) On Error Resume Next For I = 1 To UBound(ArrData, 1) Set CollDummy1 = Nothing Set CollDummy2 = Nothing Coll.Add Key:=ArrData(I, 3), Item:=Array(Coll.Count + 1, CollDummy1, CollDummy2) ArrTemp = Coll(ArrData(I, 3)) ArrTemp(1).Add Key:=ArrData(I, 4), Item:=Empty ArrTemp(2).Add Key:=ArrData(I, 1), Item:=Empty P = ArrTemp(0) ArrCalc(P, 1) = ArrCalc(P, 1) + ArrData(I, 6) ArrCalc(P, 2) = ArrCalc(P, 2) + 1 Next I On Error GoTo 0 For I = 1 To UBound(ArrIn, 1) On Error Resume Next ArrTemp = Coll(ArrIn(I, 1)) If Err.Number = 0 Then ArrOut1(I, 1) = ArrCalc(ArrTemp(0), 1) ArrOut2(I, 1) = ArrCalc(ArrTemp(0), 2) ArrOut3(I, 1) = ArrTemp(1).Count ArrOut4(I, 1) = ArrTemp(2).Count End If On Error GoTo 0 Next I Application.ScreenUpdating = False With Sheets("Rank") .Range("D10").Resize(UBound(ArrOut1, 1), 1).Value = ArrOut1 .Range("I10").Resize(UBound(ArrOut2, 1), 1).Value = ArrOut2 .Range("N10").Resize(UBound(ArrOut3, 1), 1).Value = ArrOut3 .Range("S10").Resize(UBound(ArrOut4, 1), 1).Value = ArrOut4 End With Application.ScreenUpdating = True End Sub تقبلوا تحياتي

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

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

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

جرب هذا الملف ss salim.zip

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

عملتلك برنامج تحويل الارقام كمان دا الواحد بقي خبير خبرة مستخبرتشي علي حد اه نسيت اقول ياريت تغيرر اسم الظهور بالمنتدى للغة العربية لسهولة التعامل الحل هنا وانسخ براحتك من اي برنامج.rar

انا بحب التحدى ياعم صقر انا احط ايدي علي المشكلة تلاقيني فريره بس احط ايدي علي المشكلة بس انا كسبت التحدي test.rar هاااااااا انا قد التحدي المشكلة الفاصلة بس تعمل بحث واستبدال وتحط علاة ال فاصلة وتنزل مكانها . بوينت دي

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

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

السلام عليكم اخواني بدأت بأرشفة مواضيع أرشيف الأكسس , و هذا ماتم انجازه حتى الآن , حيث المواضيع كثيره , و سأتم العمل ان شاء الله تباعا و ليكن كل يوم عدة مواضيع مثلا , و يتم اضافتها على هذا الموضوع لحين الانتهاء , ثم نبدأ بتنقيح مواضيع المنتدى العام , و اضافة الجديد منه الى هذا الموضوع . و في حال الانتهاء كاملا من العمل يتم نشره في صفحه جديدة للأعضاء . و من يرغب من الأخوه المساعده , فليتفضل مشكورا : أولا : أرشيف الجداول دوره متكامله في تصميم جداول الأكسس مثال عملي لتحليل و تصميم النظم الوصايا السبع للمبتدئين بالأكسس أنواع العلاقات بين الجداول مع مثال عملي قناع الادخال في الأكسس تنسيقات الأرقام و أمثله عليها البحث ضمن الجدول عن القيمه المقابله في جدول آخر كيفية تحويل حقل الى مربع تحرير و سرد لعرض أكثر من قيمة فيه تعلم الأكسس من خلال 4 ملفات وورد تعلم الأكسس بالصوت و الصورة قوالب تصميم قواعد بيانات جاهزة NorthWind شرح و تحليل قاعدة البيانات الشهيرة

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

لا مستحيل عند الدكتور اكسل جرب هذا الملف show_names_1_2_by letters.zip

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

اخي عبد العزيز انت اخويا ولازم اساعدك اتفضل التوضيح هنا بعد اذن الغالي انا سايب الكومنت فاضي عشان تطبق بردو TestWAV.rar

السلام عليكم ما نوع الحقول التي تريد اضافتها وضح مع التفصيل

السلام عليكم تحدي حقيقي للخبراء ،، ولم اجد له حل بخبرتي .. عندي ملف اكسل قمت بتصدير خلاياه من برنامج محاسبي /أفاق/ ولكن الارقام لا يمكنني وضعها في معادلات ولا يقرأها اكسل كارقام ولو قمت بتعديل الخصائص لها //كأنها يقرأها كصورة\\ وفي المرفقات محاولة لعمل معادلة بسيطة لاستخراج سعر المستهلك من سعر التكلفة ولكن لا جدوى والدليل موجود في المرفقات test.rar

هذا للمسح الداتا المنقوله Sub ClearConstants_1() Dim Sh As Worksheet Dim Rr, Cll Set Sh = Sheets("Rank") With Sh Rr = 10: Cll = 28 Union(.Range(Cells(Rr, 4), Cells(Cll, 4)), .Range(Cells(Rr, 9), Cells(Cll, 9)), _ .Range(Cells(Rr, 14), Cells(Cll, 14)), .Range(Cells(Rr, 19), Cells(Cll, 19))).ClearContents End With End Sub والرساله استبدل الكود المسمى Ali_Count بالتالي او انسخ هات الى اخر الكود قبل End Sub Sub Ali_Count() Dim Sh As Worksheet Dim R, Rr, Cll Set Sh = Sheets("Rank") With Sh Rr = 10: Cll = 28 For R = Rr To Cll If .Cells(R, 2) <> "" Then .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False) .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False) .Cells(R, 14) = Ali(4, 1, .Cells(R, 2), True) .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True) End If Next End With MsgBox "تم بحمد الله ", vbInformation, "تمت العمليه" Set Sh = Nothing End Sub

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

السلام عليكم لو افترضنا أن التكست بوكس هو TextBox1 ضع الكود التالي في موديول الفورم Option Explicit Private Const KL_NAMELENGTH = 9 #If Win64 Then Private Declare PtrSafe Function LoadKeyboardLayoutA Lib "user32" (ByVal pwszKLID As String, ByVal flags As Long) As LongPtr Private Declare PtrSafe Function ActivateKeyboardLayoutA Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As LongPtr, ByVal flags As Long) As LongPtr Private Declare PtrSafe Function UnloadKeyboardLayoutA Lib "user32" Alias "UnloadKeyboardLayout" (ByVal HKL As LongPtr) As Long Private Declare PtrSafe Function GetKeyboardLayoutNameA Lib "user32" (ByVal pwszKLID As String) As Long #Else Private Declare Function LoadKeyboardLayoutA Lib "user32" (ByVal pwszKLID As String, ByVal flags As Long) As Long Private Declare Function ActivateKeyboardLayoutA Lib "user32" Alias "ActivateKeyboardLayout" (ByVal HKL As Long, ByVal flags As Long) As Long Private Declare Function UnloadKeyboardLayoutA Lib "user32" Alias "UnloadKeyboardLayout" (ByVal HKL As Long) As Long Private Declare Function GetKeyboardLayoutNameA Lib "user32" (ByVal pwszKLID As String) As Long #End If #If Win64 Then Dim HKLsystem As LongPtr, HKLarabic As LongPtr #Else Dim HKLsystem As Long, HKLarabic As Long #End If Private Sub TextBox1_Enter() ActivateKeyboardLayout HKLarabic End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) ActivateKeyboardLayout HKLsystem End Sub Private Sub UserForm_Initialize() HKLsystem = LoadKeyboardLayout(GetKeyboardLCID) HKLarabic = LoadKeyboardLayout(1025) End Sub Private Sub UserForm_Terminate() ActivateKeyboardLayout HKLsystem UnloadKeyboardLayout HKLarabic End Sub Private Function GetKeyboardLCID() As Long Dim KLID As String * KL_NAMELENGTH GetKeyboardLayoutNameA KLID GetKeyboardLCID = CLng("&H" & KLID) End Function #If Win64 Then Private Function LoadKeyboardLayout(ByVal LCID As Long) As LongPtr #Else Private Function LoadKeyboardLayout(ByVal LCID As Long) As Long #End If Dim KLID As String * KL_NAMELENGTH KLID = Right(String(KL_NAMELENGTH - 1, "0") & Hex(LCID), KL_NAMELENGTH - 1) & vbNullChar LoadKeyboardLayout = LoadKeyboardLayoutA(KLID, 0) End Function #If Win64 Then Private Function UnloadKeyboardLayout(ByVal HKL As LongPtr) As Boolean #Else Private Function UnloadKeyboardLayout(ByVal HKL As Long) As Boolean #End If UnloadKeyboardLayout = UnloadKeyboardLayoutA(HKL) <> 0 End Function #If Win64 Then Private Function ActivateKeyboardLayout(ByVal HKL As LongPtr) As LongPtr #Else Private Function ActivateKeyboardLayout(ByVal HKL As Long) As Long #End If ActivateKeyboardLayout = ActivateKeyboardLayoutA(HKL, 0) DoEvents End Function

تم التعديل السبب تفعيل حمايه للورقه تم التعديل جرب المرفق مصروفات-111.rar عذرا اخي وائل لم ارى ردك الا بعد المشاركه لا داعي لاي اعتذار اخي فنحن نتعلم منكم وفقكم الله لمنفعة الامة

السلام عليكم تم التعديل السبب تفعيل حمايه للورقه تم التعديل جرب المرفق مصروفات-111.rar عذرا اخي وائل لم ارى ردك الا بعد المشاركه

الله عليك يا أ / محمد ما شاء الله زادك الله من العلم الكثير والكثير

وعليكم السلام تفضل أخي 444.rar

السلام عليكم اخى الكريم جرب هذا الحل Book1.rar

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

السلام عليكم بعد اذن الاستاذ الحبيب عادل حنفي مجرد اثراء للموضوع حل بطريقة اخرى جرب الكود التالي Sub Ali_Trq() Dim Lr As Long, Rw As Long, Rww As Long Dim Rng_Dp As Range, Rng_D As Range, Rng_Empty As Range Dim Sh As Worksheet, Sht As Worksheet '************************************************ ' اسم الورقة التي بها الجدول Set Sh = Sheets("Sheet1") '************************************************ ' اسم الورقة التي تريد بها الجدول بعد الترتيب Set Sht = Sheets("Sheet2") ' Application.ScreenUpdating = False Lr = Split(Sh.UsedRange.Address, "$")(4) Sh.Range("A1:J" & Lr).Copy '=========================================== With Sht .Range("A1").PasteSpecial xlPasteAll .Range("A1").PasteSpecial xlPasteColumnWidths .Activate Set Rng_Dp = .Range("D" & Lr + 1) Set Rng_Empty = .Range("A" & Lr + 1) Set Rng_D = .Range("A" & Lr + 1) For Rw = 2 To Lr If Application.CountIf(.Range("D1:D" & Rw), .Range("D" & Rw)) > 1 Then Set Rng_Dp = Union(Rng_Dp, .Range("D" & Rw)) End If '=========================================== If IsNumeric(.Cells(Rw, 1)) Then If Application.CountIf(.Range("A1:A" & Rw), .Range("A" & Rw)) > 1 Then Set Rng_D = Union(Rng_D, .Range("A" & Rw)) End If End If '=========================================== Next Rw Rng_Dp.Value = "": Rng_D.Value = "" Lr = Split(.UsedRange.Address, "$")(4) For Rww = 2 To Lr If .Cells(Rww, 1) = "" Then Set Rng_Empty = Union(Rng_Empty, .Range("A" & Rww)) End If Next '=========================================== Rng_Empty.EntireRow.Delete xlShiftUp .Range("A1:J" & Lr).Borders.Color = 1 Set Rng_Dp = Nothing Set Rng_Empty = Nothing Set Rng_D = Nothing End With Application.ScreenUpdating = True End Sub

اخى الكريم اطلع على الملف التالى للاستاذ / عمر الحسينى ... جزاه الله خيراً تغيير اللغة.rar

السلام عليكم اخي مرفق ملف في شيت "تسجيل الدخول للالة" عند اختيارك لاسم طالب سيتم مباشرة تسجيل 1 في شيت "الملخص" في خانة اليوم الموافق لما سجلته في شيت "تسجيل الدخول للصالة" يجب فيه مراعاة الاتي كلمة الطالب لا تتغير فان الكود يعتمد عليها العامود الذي اوله رقم اليوم يعتمد عليه الكود جرب الملف واخبرني النتيجة تحياتي برنامج دخول الطلاب إلى الصالة الترفيهية2.rar

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

الاخوة الاعضاء يمكن مراجعه الراوبط التالى لكى يتم تشغيل اى ملف exe على جهازك https://support.microsoft.com/ar-sa/kb/950505 http://www.solvusoft.com/ar/file-extensions/file-extension-exe/ http://www.traidnt.net/vb/traidnt2201842/

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

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

الله يعطيك العافية روووووووووووووووووعة والله روووووعة شيء جميل بارك الله فيك

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