ياسر خليل أبو البراء

بارك الله فيك أخي وحبيبي الغالي رجب جاويش على أكوادك الرائعة ومرحباً بعودتك كمشرف في المنتدى تقبل تحياتي

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

وجزيت خيراً بمثل ما دعوت لي وزيادة أخي الغالي أحمد وبارك الله فيك على دعائك الطيب المبارك وعلى متابعتك الممتازة للمنتدى تقبل تحياتي

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

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

أقترح عليك طرح الموضوع من جديد لعلك تجد المساعدة بشكل أفضل ..لأن الموضوع طول بدون الوصول لنتيجة مرضية لك .. قم بطرح موضوع جديد وارفق ملف معبر عن الملف الأصلي مع تقليل حجم البيانات بحيث لا تكون الملفات المرفقة كبيرة في الحجم .. ووضح المطلوب بإرفاق النتائج المطلوبة .. تقبل تحياتي

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

جزيتم خيراً إخواني الكرام على مروركم العطر بالموضوع إليكم الكود الثالث في المشاركة الأولى Sub sRange_Move() With Sheet2 .Range("A9:C12").ClearContents .Range("A9:C12").Value = Sheet1.Range("A9:C12").Value End With MsgBox "تم الترحيل بنجاح", 64 End Sub تقبلوا تحياتي Transfer Data YasserKhalil.rar

أخي الكريم يرجى تغيير اسم الظهور للغة العربية بدون الإطلاع على المرفق إليك فكرة قد تفيدك .. قم بعمل إجراء فرعي منفصل واستدعي كلاً من الكودين بالتتالي .. Call Macro1 Call Macro2 حيث Macro1 اسم الإجراء الأول المراد تنفيذه أولاً و Macro2 اسم الإجراء الفرعي الثاني المراد تنفيذه بعد الأول .. إذا لم يكن المطلوب فيرجى توضيح المطلوب وما هو الهدف من الكود بالضبط ليساعدك الأخوة الأعضاء تقبل تحياتي

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

أخي الكريم محمود جرب الكود التالي عله يكون المطلوب ... Private Sub CommandButton1_Click() Dim Coll As New Collection, arrData, arrOut, arrStrSheet, strSheet, arrBlank, arrTemp Dim I As Long, J As Long, K As Long, strKey As String arrStrSheet = Array("المشتروات", "المبيعات") ReDim arrBlank(0 To 4) For K = LBound(arrStrSheet) To UBound(arrStrSheet) With Sheets(arrStrSheet(K)) arrData = .Range("C6:E" & Application.Max(.Cells(.Rows.Count, "C").End(xlUp).Row, .Range("C6").Row)).Value On Error Resume Next For I = 1 To UBound(arrData, 1) strKey = Trim$(arrData(I, 1) & Chr$(2) & arrData(I, 2)) arrTemp = arrBlank arrTemp = Coll(strKey) arrTemp(0) = arrData(I, 1) arrTemp(1) = arrData(I, 2) arrTemp(K + 2) = arrTemp(K + 2) + arrData(I, 3) Coll.Remove strKey Coll.Add Key:=strKey, Item:=arrTemp Next I On Error GoTo 0 End With Next K ReDim arrOut(1 To Coll.Count, 1 To 5) I = 0 For Each arrTemp In Coll I = I + 1 For J = 0 To 3 arrOut(I, J + 1) = arrTemp(J) Next J arrOut(I, 5) = arrOut(I, 3) - arrOut(I, 4) Next arrTemp With Sheets("جرد البضاعة").Range("B5") .CurrentRegion.Offset(1, 1).ClearContents If Coll.Count Then With .Offset(1, 1).Resize(UBound(arrOut, 1), UBound(arrOut, 2)) .Value = arrOut .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(2), Order2:=xlAscending, Header:=xlNo End With End If End With End Sub وإليك الملف المرفق فيه تطبيق الكود تقبل تحياتي Transfer Purchases & Sales Using Arrays.rar

الأخ العزيز كريم بارك الله فيك وجزاك الله كل خير ملف جميل جداً ومتميز .. الأخ الحبيب أحمد الملف الذي أرفقه الأخ كريم عبارة عن موديول تم تصديره ليكون ملف منفصل ، ويتم استيراده بالشكل التالي : روح لمحرر الأكواد ..كليك يمين في نافذة المشروع .. اختار الأمر Import File .. حدد مكان الملف الذي أرفقه الأخ كريم بعد فك ضغطه بالطبع والذي امتداده Bas .. وأخيراً انقر الأمر Open .. ستجد أن الموديول قد أضيف في نافذة المشروع وإليك الكود الموجود بالملف بعد تنسيقه بشكل مناسب (أحب تنسيق الأكواد ليسهل التعامل معها) Private Function ChangeToDigits1(Temp As String) As String If Temp = "0" Then ChangeToDigits1 = "" GoTo Finish End If If Temp = "1" Then ChangeToDigits1 = "واحد" GoTo Finish End If If Temp = "2" Then ChangeToDigits1 = "اثنان" GoTo Finish End If If Temp = "3" Then ChangeToDigits1 = "ثلاثة" GoTo Finish End If If Temp = "4" Then ChangeToDigits1 = "أربعة" GoTo Finish End If If Temp = "5" Then ChangeToDigits1 = "خمسة" GoTo Finish End If If Temp = "6" Then ChangeToDigits1 = "ستة" GoTo Finish End If If Temp = "7" Then ChangeToDigits1 = "سبعة" GoTo Finish End If If Temp = "8" Then ChangeToDigits1 = "ثمانية" GoTo Finish End If If Temp = "9" Then ChangeToDigits1 = "تسعة" GoTo Finish End If Finish: End Function Private Function ChangeToDigits2(Temp As String) As String Dim Digit1 As String Dim Digit2 As String Dim Between As String Digit2 = Left(Temp, 1) Digit1 = Right(Temp, 1) If Digit2 = "1" Then ChangeToDigits2 = "عشر" GoTo Finish End If If Digit2 = "2" Then ChangeToDigits2 = "عشرون" GoTo Finish End If If Digit2 = "3" Then ChangeToDigits2 = "ثلاثون" GoTo Finish End If If Digit2 = "4" Then ChangeToDigits2 = "أربعون" GoTo Finish End If If Digit2 = "5" Then ChangeToDigits2 = "خمسون" GoTo Finish End If If Digit2 = "6" Then ChangeToDigits2 = "ستون" GoTo Finish End If If Digit2 = "7" Then ChangeToDigits2 = "سبعون" GoTo Finish End If If Digit2 = "8" Then ChangeToDigits2 = "ثمانون" GoTo Finish End If If Digit2 = "9" Then ChangeToDigits2 = "تسعون" GoTo Finish End If Finish: If Digit1 = "0" Then Digit1 = "" Between = "" Else If Digit2 = "1" Then Between = " " Digit1 = ChangeToDigits1(Digit1) Else Between = " و " Digit1 = ChangeToDigits1(Digit1) End If End If If Digit2 = "0" Then Between = "" ChangeToDigits2 = Digit1 & Between & ChangeToDigits2 If Temp = "00" Then ChangeToDigits2 = "" If Temp = "11" Then ChangeToDigits2 = "احدى عشر" If Temp = "12" Then ChangeToDigits2 = "اثنا عشر" If Temp = "10" Then ChangeToDigits2 = "عشرة" End Function Private Function ChangeToDigits3(Temp As String) As String Dim Between As String Dim Handred As String Dim First As String Dim Second As String Handred = " مائة" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits2(Right(Temp, 2)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Handred = "" End If If First = "واحد" Then First = "" If First = "اثنان" Then First = "" Handred = "مئتا" End If ChangeToDigits3 = First & Handred & Between & Second If Temp = "000" Then ChangeToDigits3 = "" End Function Private Function ChangeToDigits4(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " آلاف" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "الف" End If If First = "اثنان" Then First = "" Thousand = "الفا" End If ChangeToDigits4 = First & Thousand & Between & Second If Temp = "0000" Then ChangeToDigits4 = "" End Function Private Function ChangeToDigits5(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " ألف" First = ChangeToDigits2(Left(Temp, 2)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "ألف" End If If First = "اثنان" Then First = "" Thousand = "ألفا" End If ChangeToDigits5 = First & Thousand & Between & Second If Temp = "00000" Then ChangeToDigits5 = "" End Function Private Function ChangeToDigits6(Temp As String) As String Dim Between As String Dim Thousand As String Dim First As String Dim Second As String Thousand = " الف" First = ChangeToDigits3(Left(Temp, 3)) Second = ChangeToDigits3(Right(Temp, 3)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Thousand = "" End If If First = "واحد" Then First = "" Thousand = "ألف" End If If First = "اثنان" Then First = "" Thousand = "ألفا" End If ChangeToDigits6 = First & Thousand & Between & Second If Temp = "000000" Then ChangeToDigits6 = "" End Function Private Function ChangeToDigits7(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = "ملايين" First = ChangeToDigits1(Left(Temp, 1)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = "مليون" End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits7 = First & Million & Between & Second End Function Private Function ChangeToDigits8(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = " مليون " First = ChangeToDigits2(Left(Temp, 2)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = " مليون " End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits8 = First & Million & Between & Second End Function Private Function ChangeToDigits9(Temp As String) As String Dim Between As String Dim Million As String Dim First As String Dim Second As String Million = " مليون " First = ChangeToDigits3(Left(Temp, 3)) Second = ChangeToDigits6(Right(Temp, 6)) If Second <> "" Then Between = " و " Else Between = "" If First = "" Then Between = "" Million = "" End If If First = "واحد" Then First = "" Million = " مليون " End If If First = "اثنان" Then First = "" Million = "مليونا" End If ChangeToDigits9 = First & Million & Between & Second End Function Public Function ChangeThisNumber(Allnumber As String) As String Dim Temp As String Dim Backed As String Dim Backed2 As String Dim Length As Integer Dim bigCur, smallCur As String Dim intNum As String Dim FloatNum As String Dim I As Integer Dim Found As Boolean Allnumber = Trim(Allnumber) If Not IsNumeric(Allnumber) Then ChangeThisNumber = "خطأ في الإدخال" Exit Function End If I = 1 Do While I <> Len(Allnumber) + 1 If Mid(Allnumber, I, 1) <> "." Then intNum = intNum & Mid(Allnumber, I, 1) Else Found = True GoTo Float End If I = I + 1 Loop Float: If Found Then I = I + 1 Do While I <> Len(Allnumber) + 1 FloatNum = FloatNum & Mid(Allnumber, I, 1) I = I + 1 Loop End If Temp = intNum Length = Len(Temp) If Length = 1 Then Backed = ChangeToDigits1(Temp) If Length = 2 Then Backed = ChangeToDigits2(Temp) If Length = 3 Then Backed = ChangeToDigits3(Temp) If Length = 4 Then Backed = ChangeToDigits4(Temp) If Length = 5 Then Backed = ChangeToDigits5(Temp) If Length = 6 Then Backed = ChangeToDigits6(Temp) If Length = 7 Then Backed = ChangeToDigits7(Temp) If Length = 8 Then Backed = ChangeToDigits8(Temp) If Length = 9 Then Backed = ChangeToDigits9(Temp) Temp = FloatNum Length = Len(Temp) If Length = 1 Then Backed2 = ChangeToDigits1(Temp) If Length = 2 Then Backed2 = ChangeToDigits2(Temp) If Length = 3 Then Backed2 = ChangeToDigits3(Temp) If Length = 4 Then Backed2 = ChangeToDigits4(Temp) If Length = 5 Then Backed2 = ChangeToDigits5(Temp) If Length = 6 Then Backed2 = ChangeToDigits6(Temp) If Length = 7 Then Backed2 = ChangeToDigits7(Temp) If Length = 8 Then Backed2 = ChangeToDigits8(Temp) If Length = 9 Then Backed2 = ChangeToDigits9(Temp) smallCur = StrSmallNameCurrency bigCur = StrLargeNameCurrency Dim Filse As String Dim Between As String Dim JD As String Between = " و " If Backed <> "" Then JD = " " & bigCur & " " Else JD = "" Between = "" End If If Backed2 <> "" Then Filse = " " & smallCur & " " Else Filse = "" Between = "" End If ChangeThisNumber = Backed & JD & Between & Backed2 & Filse End Function استخدام الدالة المعرفة ضع رقم في الخلية A1 وفي الخلية B1 ضع المعادلة التالية =ChangeThisNumber(A1) وإليك الملف المرفق مطبق فيه الدالة المعرفة .. تقبل وافر تقديري واحترامي Spell Number UDF Function Karim.rar

الكود الثاني في المشاركة الأولى Sub MessageBoxTutorial() Dim Msg As String, Ans As Integer donkeyain: Msg = "[ حصن لوقاية الإنسان من شياطين الإنس والجان ] " Ans = MsgBox(Msg, vbYesNo) If Ans = vbNo Then If MsgBox("هل تود الذهاب إلى الدعاء", vbYesNo) = vbYes Then GoTo donkeyain Else Exit Sub End If Else MsgBox "تحصنت بذي العزة والجبروت واعتصمت برب الملكوت" & vbNewLine & "وتوكلت على الحي الذى لا يموت. اصرف عنا الأذي إنك على كل شئ قدير" End If End Sub Message Box MsgBox Tutorial.rar

أخي الحبيب أحمد إليك هدية مني ملف مرفق يمكنك ترجمة أسماء الدوال من الإنجليزية للفرنسية أو العكس ويوجد لغات أخرى .. تقبل تحياتي Translation Of Functions Officena YasserKhalil.rar

أخي الفاضل محمد يمكنك إرسال الإيميل الخاص بك على الفيس بوك حتى أقوم بإضافتك .. تقبل تحياتي

أخي الكريم أرسلان ننتظر منك تغيير اسم الظهور للغة العربية بعد إذن أخي وحبيبي قنديل الصياد سأقوم بعمل ملفات مرفقة للأكواد الموجودة في الموضوع كل كود في ملف مرفق منفصل ليستفيد منه الجميع ..حيث لاحظت أن الملف المرفق الاستفادة منه أفضل من الأكواد بدون ملفات مرفقة الملف الأول : الكود الأول في المشاركة الأولى (تم التعديل بما يتناسب مع عدم استخدام كلمة Select التي تبطيء من عمل الكود) Sub Officena() Range("J1").FormulaR1C1 = "بسم الله الرحمن الرحيم" Range("J2").FormulaR1C1 = "تحياتى لكل أساتذتي بمنتديات أوفيسنا" Range("J3").FormulaR1C1 = "الأستاذ / عبد الله باقشير" Range("J4").FormulaR1C1 = "الأستاذ / أحمد فضيلة" Range("J5").FormulaR1C1 = "الأستاذ / رجب جاويش" Range("J6").FormulaR1C1 = "الأستاذ / حماده عمر" Range("J7").FormulaR1C1 = "الأستاذ / هاني عدلي" Range("J8").FormulaR1C1 = "الأستاذ / جمال عبد السميع " Range("J9").FormulaR1C1 = "الأستاذ / احمد عبد الناصر " Range("J10").FormulaR1C1 = "الأستاذ / شوقى ربيع" Range("J11").FormulaR1C1 = "الأستاذ / جمال دغيدي" Range("J12").FormulaR1C1 = "الأستاذ / طارق محمود" Range("J13").FormulaR1C1 = "الأستاذ / ضاحي الغريب" Range("J14").FormulaR1C1 = "الأستاذ / عبد الله المجرب" Range("J15").FormulaR1C1 = "الأستاذ / سعيد بيرم" Range("J16").FormulaR1C1 = "تلميذكم / ياسر خليل" End Sub تقبل تحياتي Officena Staff YasserKhalil.rar

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

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

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

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

أخي الكريم أرسلان أهلاً بك في المنتدى ونورت بين إخوانك يرجى تغيير اسم الظهور للغة العربية حتى لو كنت تركي .. تقبل تحياتي

بارك الله فيك أخي الفاضل محمد أبو صهيب أعتقد أن المشكلة التي لدى أخونا أحمد سببها Microsoft Web Browser لاتعمل مع بعض نسخ الأوفيس ..فهي لا تعمل لدي في النسخة أوفيس 2013 ..لكني مجرب الأداة في نسخ سابقة وتعمل بشكل جيد ... لو فيه بديل غير هذه الأداة يكون متوافق مع جميع النسخ يكون أفضل تقبل تحياتي

أخي الكريم سامح طاهر هلا غيرت اسم الظهور للغة العربية ليعبر عن شخصكم الكريم جرب الكود التالي عله يفي بالغرض .. سيتم وضع معادلات في الخلية E1 والخلية F1 في الملفات المغلقة كما سيتم إخفاء العمودين C و D .. يمكنك التعديل بما يتناسب مع ملفك (ولا تطلب التعديل طالما أنك لم ترفق ملف من البداية .. طبعاً بهزر معاك .. ) ولكن للأسف الموضوعات التي لا يتم إرفاق ملف فيها غالباً ما يتم فيه تقديم مشاركات كثيرة حتى نصل للمطلوب وستلاحظ ذلك بنفسك ..بخلاف الموضوعات التي يكون فيها ملف مرفق Sub LoopThroughClosedWBs() Dim WBK As Workbook Dim FolderPath As String Dim FileName As String Dim Counter As Double FolderPath = ThisWorkbook.Path & "\" FileName = Dir(FolderPath & "*.xl*") Application.ScreenUpdating = False Application.Calculation = xlManual Do While FileName <> "" If FileName <> ThisWorkbook.Name Then Set WBK = Workbooks.Open(FolderPath & FileName) With WBK.Sheets("Sheet1") .Range("E1").Formula = "=SUM(A1:B1)" .Range("F1").Formula = "=A1*B1" .Columns("C:D").Hidden = True End With WBK.Close SaveChanges:=True End If FileName = Dir() Loop Application.Calculation = xlAutomatic Application.ScreenUpdating = True MsgBox "Finished ...", 64 End Sub وإليك الملف المرفق من عندي تقبل تحياتي Loop Through Closed Workbooks & Type Formulas And Hide Columns YasserKhalil.rar

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

أخي الفاضل محمد علي بارك الله فيك وجزاك الله كل خير ممكن تحاول في الملف عشان يشتغل على أوفيس 64 بت .. تقبل تحياتي