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

ماشى يا عم سليم وانا قبلت التحدى كنا عايزين نكون متواضعين بس يالا طالما قلبتوها تحدى دا حل لاى تصدير من اى برنامج محاسبى الى ملف الاكسيل باستخدام تحديد الفاصله العشريه المستخدمه بعيد عن الاكواد وبعيد عن المعادلات شاهد الصور وانا مازالت منتظر اجابته عن هل بعد عملية التصدير وبتدخل للاكسيل تلاقى فى على الخلايا علامة مثلث خضراء صغيره جدا هل رائيتها ام لا ؟ لو الاجابه نعم فالحل بضغط زر صغيره مرفق ملف يا عم انس وبلاش عبارات التحدى دى تانى لان من تواضع لله رافعه لان العلم ملوش كبير وملوش نهاية وفوق كل زى علم عليم 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 هاااااااا انا قد التحدي المشكلة الفاصلة بس تعمل بحث واستبدال وتحط علاة ال فاصلة وتنزل مكانها . بوينت دي

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

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

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

استاذى العزيز الاستاذ / ياسر خليل أبو البراء اشكرك على سرعة الرد والاستجابة لطلبى جعلك الله عونا لأمثالى وجعل هذا العمل فى ميزان حسناتك هذا هو المطلوب فعلا شكرا شكرا شكرا

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

أخي الغالي سعد عابد أحبك الله الذي أحببتنا فيه .. جزيت خيراً على مرورك العطر بالموضوع وفي انتظار مساهماتك وإبداعاتك (لا تتأخر علينا)

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

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

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

السلام عليكم كثر الطلب على كود يعيد تحجيم النماذج لتتناسب مع حجم شاشة المستخدم وهذا الكود قد وضعته في ملف واحد وهي عبارة عن مثالين داخل ملف أكسس واحد عند فتح البرنامج إفتح النموذج الي اسمه : frmwelcome وهذا للمثال الأول أما للمثال الثاني افتح النموذج الي اسمه : frmwelcome2 وستجد ما يسركم من الكودات عسى الله ينفع بها الجميع والسلام عليكم Example_1+2_ For changing ScreenDPI.rar

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

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

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

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

الأخ الكريم اسكندراني قمت بشرح الكود بشكل سريع عله يفيدك في التعديل كما قمت بتغيير الأرقام بأسماء الأعمدة المشار إليها لتسهيل عملية التعديل عليك حتى تستطيع أن تعدل على ملفك بنفسك Sub Ali_Tr() 'تعريف المتغيرات Dim Shr As Worksheet Dim Wsh As Worksheet Dim Rng As Range Dim LR, II, Rww%, IM, RW Dim MOf, Amel, AGra Dim MOf1, Amel1, AGra1 'تعيين قيمة للمتغير ليساوي ورقة العمل الأولى المطلوب العمل عليها Set Wsh = Sheet1 With Wsh 'تعيين آخر صف به بيانات في ورقة العمل الأولى LR = .Cells(.Rows.Count, 1).End(xlUp).Row 'إلى آخر خلية بها بيانات في العمود الخامس [D3] مسح النطاق بدايةً من الخلية .Range(.Cells(3, "D"), .Cells(LR, "E")).ClearContents End With 'حلقة تكرارية لكل أوراق العمل بالمصنف For Each Shr In ThisWorkbook.Worksheets 'إذا لم يكن اسم ورقة العمل يساوي اسم ورقة العمل الأولى يتم تنفيذ الأسطر التالية 'أي أنه يتم استثناء ورقة العمل الأولى من تلك الأسطر بينما تنفذ الأسطر على بقية الأوراق If Not Shr.Name = Wsh.Name Then 'بدء التعامل مع ورقة العمل التي انطبق عليها الشرط بأنها ليست الورقة الأولى With Shr 'حلقة تكرارية من الصف الثالث إلى آخر صف به بيانات For II = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row 'إذا لم تكن الخلية في العمود الرابع في الصف المحدد في الحلقة التكرارية فارغة 'فإذا لم تكن فارغة يتم تنفيذ الأسطر التالية [D] أي أنه يتم اختبار الخلية في العمود 'أما إذا كانت فارغة يتم الانتقال للصف التالي لاختبار الخلية التالية في العمود الرابع If .Cells(II, "D") <> "" Then 'تعيين قيمة للمتغير ليساوي رقم الصف Rww = .Cells(II, "B").Row 'حلقة تكرارية من الصف الثالث إلى آخر صف به بيانات في الورقة الأولى For IM = 3 To Wsh.Cells(Wsh.Rows.Count, 1).End(xlUp).Row 'إذا كانت الخلية في العمود الثاني في أوراق الموظفين تساوي الخلية في العمود الثاني 'أي أنه يتم المقارنة بين اسم العميل في ورقة الموظف والورقة الأولى فإذا تطابق الاسم 'ينفذ التالي If .Cells(Rww, "B") = Wsh.Cells(IM, "B") Then 'إذا كانت الخلية في العمود الرابع في الورقة الأولى ليست فارغة يتم تنفيذ التالي If Wsh.Cells(IM, "D") = "" Then 'تعيين قيمة للمتغير ليساوي رقم الصف الذي يحوي اسم العميل من الورقة الأولى RW = Wsh.Cells(IM, "B").Row 'الخلية في العمود الرابع في الصف الذي يحوي اسم العميل في الورقة الأولى يساوي الخلية في العمود الرابع في الصف المحدد في الحلقة التكرارية Wsh.Cells(RW, "D") = .Cells(IM, "D") 'الخلية في العمود الخامس في الصف الذي يحوي اسم العميل في الورقة الأولى يساوي اسم ورقة عمل الموظف Wsh.Cells(RW, "E") = .Name 'أما إذا كانت الخلية في العمود الرابع في الأولى تساوي قيمة الخلية في العمود الرابع في ورقة الموظف ElseIf Wsh.Cells(IM, "D") = .Cells(Rww, "D") Then 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الخامس ليحمل اسم الموظف 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الثاني ليحمل اسم العميل MOf1 = .Cells(IM, "E"): Amel1 = .Cells(IM, "B") 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الرابع ليحمل الإجراء 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الخامس في الورقة الأولى ليحمل اسم الموظف AGra1 = .Cells(IM, "D"): MOf = Wsh.Cells(IM, "E") 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الثاني في الورقة الأولى ليحمل اسم العميل 'تعيين قيمة للمتغير ليساوي قيمة الخلية في العمود الرابع في الورقة الأولى ليحمل الإجراء Amel = Wsh.Cells(IM, "B"): AGra = Wsh.Cells(IM, "D") 'إظهار رسالة في حالة التضارب في إدخال البيانات 'أي أنه عند اتخاذ إجراء لعميل عند أكثر من موظف تظهر رسالة تفيد بذلك MsgBox "البند المسمى :" & " " & Amel & " موجود مسبقاً في ورقة : " & " " & MOf & vbCrLf & " بالاجراء :" & " " & AGra & vbNewLine & " " & " وكرر في ورقة :" & " " & .Name & " " & " للعميل : " & Amel1 'التخطي للانتقال لصف جديد GoTo Skipper End If End If Skipper: 'الانتقال للصف التالي في الورقة الأولى Next IM End If 'الانتقال للصف التالي في ورقة الموظف المعنية Next II End With End If 'الانتقال لورقة الموظف التالية Next Shr End Sub أرجو أن ينفعك الأمر تقبل تحياتي

السلام عليكم اخى الكريم جرب هذا الحل 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

جرب أضف كلمة Ptrsafe بعد كلمة Declare >> إذا لم يفلح الأمر معك سأوافيك بالكود ليلاً إن شاء ربي

جرب هذا الملف ايضا للقدير استاذى سليم حاصبيا تغيير اللغة اوتوكاتيكياً.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/

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

السلام عليكم عملت لك اثنتين اكمل البقية على هذا المنوال db4.rar

السلام عليكم ارسل لكم اليوم برنامج محاسبي بسيط يحتوي على ادوات تحكم بالماكرو ارجوا ان ينال اعجابكم لا تبخلو علينا بالردود _____________.xls.rar