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

السلام عليكم الكثير يسال عن اصلاح ملف اكسيل تالف وجدت هذا البرنامج ارجو ان ينال اعجابكم برنامج Excel File Repair 10.10 لاصلاح ملفات اكسل التالفة , برنامج يساعدك على استرجاع ملفات برنامج الاكسل الشهير Excel في حالة تعرضه لعطب بسبب فايروس او ملف تخريبي او تلف بعض ملفات النظام او خطأ من المستخدم تحميل برنامج Excel File Repair 10.10.01

السلام عليكم ورحمة الله وبركاته كل عام وانتم بخير اطلب المسامحة ممن راسلني ولم يجد رد مني هديتي لكم بعد هذه الغيبة Option Explicit '========================================================" ' بسم الله الرحمن الرحيم " '========================================================" ' (دالة تحويل الرقم الى نص باللغة العربية (تفقيط " ' kh_TextNum " '========================================================" 'Num الرقم " '========================================================" 'sex جنس العملة " 'FALSE ( فارغ او صفر مذكر ) " 'TRUE ( أو اي رقم غير الصفر مؤنث ) " '========================================================" 'sNameCurr اسم العملة الرئيسية مفرد " 'pNameCurr اسم العملة الرئيسية جمع " 'NameCurrDec اسم العملة الكسرية " 'Decimal_Count طول الكسر افتراضـياً : بدون اظهار الكسر " '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" ' ملاحظات ' (اولاً : العملة الرئيسية مثنى (يقوم بها الكود تلقائيا ' مع ملاحظة اذا اسم العملة ينتهي بالتاء المربوطة ' يجب ان يكتب كذلك وليس بالهاء ' ----------------------- ' ثانياً : اذا كانت العملة الرئيسية مفرد فارغاً تعتبر ' اسماء العملات (الجمع والكسري) فارغة تلقائيا ' ----------------------- 'ثالثاً : الكلمة الابتدائية بامكانك تغييرها او تجعلها فارغة Private Const MyBegTx As String = "فقط " ' "" ' ----------------------- ' MyTNum رابعا : يمكنك التغيير (اضافة,حذف,تحرير) في الثابت ' للفئات الصفرية للرقم ادناه Private Const MyTNum As String = "ألف-آلاف/مليون-ملايين/مليار-مليارات/بليون-بلايين/بليار-بليارات/ترليون-ترليونات/تريليار-تريليارات/كدرليون-كدرليونات" '===============================================================================================================================================" 'xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" '===============================================================================================================================================" Function kh_TextNum(Num As String, Optional sex As Boolean = False, Optional sNameCurr As String = "", Optional pNameCurr As String = "", Optional NameCurrDec As String = "", Optional Decimal_Count As Byte = 2) As String Dim Spp, zt Dim i%, ii%, pr% Dim MyMid$, nCurr$, Txt$, Txt1$, Txt2$ '====================================== If Not IsNumeric(Num) Then GoTo kh_Exit Spp = Split("/" & MyTNum, "/") ii = UBound(Spp) If Num < 0 Then Num = Abs(Num) '====================================== If Val(Num) > Val(String((ii + 1) * 3, "9") & ".999") Then GoTo kh_Exit '====================================== nCurr = sNameCurr & "-" & IIf(pNameCurr = "", sNameCurr, IIf(sNameCurr = "", "", pNameCurr)) '====================================== Txt1 = Format(Num, String((ii + 1) * 3, "0") & ".000") For i = 0 To ii MyMid = Mid(Txt1, (i * 3) + 1, 3) If MyMid Then zt = Mid(Txt1, (i * 3) + 4, Len(Txt1)) zt = IIf(ii - i, Int(zt), zt) Txt2 = IIf(ii - i, Trim(Spp(ii - i)), nCurr) pr = 1 + IIf(ii - i, 1, CInt(sex)) Txt = Txt & IIf(Len(Txt), " و", "") & kh_nText(MyMid, Txt2, pr, zt, CBool(sNameCurr <> "")) End If If i = ii Then If MyMid = 0 Then Txt = Txt & IIf(Len(Txt), " ", "صفر ") & sNameCurr Next '====================================== Txt = MyBegTx & Txt & kh_dText(Num, sNameCurr, NameCurrDec, Decimal_Count) '====================================== kh_Exit: kh_TextNum = Trim(Txt) End Function ' معالجة العدد من 1 الى 999 لكل فئات الرقم Private Function kh_nText(ByVal iNum As String, ByVal oMm As String, ByVal ibs As Integer, ByVal z As Boolean, ByVal tCu As Boolean) As String Dim Sp Dim Num1%, Num2%, Num3% Dim oM$, S$, S1$, nT$, nT0$, nT1$, nT2$ '====================================== Sp = Split("واحد,إحدى,اثنتان,ثلاث,أربع,خمس,ست,سبع,ثمان,تسع,عشر,إحدى ,اثنتا ", ",") '====================================== If ibs Then S = "ة": Sp(1) = Sp(0): Sp(2) = "اثنان": Sp(11) = "أحد ": Sp(12) = "اثنا " Else S1 = "ة" oM = Trim(Split(oMm, "-")(0)) '====================================== Num1 = Left(iNum, 1) Num2 = Right(iNum, 2) Select Case Num1 Case 1: nT0 = "مائة" Case 2: nT0 = "مائتا" & IIf(ibs = 2, IIf(Num2 < 3, "", "ن"), IIf(Num2 = 0 And oM <> "", "", "ن")) Case 3 To 9: nT0 = Sp(Num1) & "مائة" End Select '========================================= Num1 = Right(iNum, 2) Select Case Num1 Case 1, 2: If nT0 <> "" Then If ibs = 2 Then nT0 = nT0 & " " & oM Case 11 To 99: If oM <> "" Then If ibs Then If z Then oM = oM & "اً" End Select '----------------------------------------- Select Case Num1 Case 1 nT = IIf(oM = "", Sp(0) & S1, oM) oM = IIf(ibs <> 2 And oM <> "", Sp(0) & S1, "") Case 2 nT = IIf(oM = "", Sp(Num1), Replace(oM, "ة", "ت") & IIf(z = 0 And ibs = 2 And tCu, "ا", "ان")) oM = IIf(ibs <> 2 And oM <> "", Sp(Num1), "") Case 3 To 10 oM = Trim(Split(oMm, "-")(1)) nT = Sp(Num1) & S Case 11, 12 nT = Sp(Num1) & Sp(10) & S1 Case 13 To 19 nT = Sp(Num1 - 10) & S & " " & Sp(10) & S1 Case 20 To 99 Num2 = Right(Num1, 1) Num3 = Left(Num1, 1) If Num3 = 2 Then nT1 = "عشرون" Else nT1 = Sp(Num3) & "ون" nT2 = Sp(Num2) & IIf(Num2 > 2, S, "") & " و" & nT1 If Num2 = 0 Then nT2 = nT1 nT = nT2 End Select '====================================== S = IIf(nT = "" Or iNum < 100, "", " و") nT = Replace(nT, Sp(8) & "ة", Sp(8) & "ية") kh_nText = Trim(nT0 & S & nT & " " & oM) '====================================== End Function ' معالجة الكسر Private Function kh_dText(ByVal dNum As String, ByVal NCur As String, ByVal Ndec As String, ByVal co As Byte) As String Dim Td$, Td1$ On Error GoTo 1 If NCur = "" Then Ndec = "" Td = Format(Round(CCur(dNum - Int(dNum)), co), "0." & String(co, "0")) If Td = 0 Or Td = 1 Then Td1 = "": GoTo 1 If Len(Ndec) Then Ndec = " " & Ndec: Td1 = Td * CVar("1" & String(co, "0")) Else Ndec = " " & NCur: Td1 = Td Td1 = " و " & Chr(40) & Td1 & Chr(41) & Ndec 1: kh_dText = Td1 End Function دالة تحويل الرقم الى نص عربي.rar ================================================= الملف المعدل: هذا المرفق بامكانية تفقيط الكسر وامكانية ادخال كلمة نهاية النص دالة تحويل الرقم الى نص عربي.rar ================================================= رابط مباشر للملف

الأستاذ / علي السلام عليكم ورحمة الله وبركاته جرب هذا الملف لعله المطلوب. Book1.rar

أخى الفاضل /krimo145 لا يقوم المشرف بحذف أى مشاركات إلا اذا كان فيها اساءة أو كلمات بها تجاوز برجاء عند استعجال الرد على موضوعك أن يكون ذلك ذلك عن طريق كلمة ( للرفع ) أخى الفاضل قمت بعمل زر حذف وزر آخر للتعديل برجاء فحص الملف المرفق واخبارى بالنتيجة Book11.rar

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

اخى محمود --------------------- كل الشكر لاستاذنا شوقى ربيع نسأل الله ان يديم عليه الصحه والعافيه -------------------------------------------------- وايضا الشكر لك لتزكيرنا بالمواضيع الجميله من الاساتذه الكبار ------------------------------------------ واسمح لى بالمشاركه x.rar

السلام عليكم حذف اشكال تلقائية والصور والنماذج في نطاق معين اشتغل معي عل اوفيس 2003 حدد النطاق داخل الكود مثلا If Not Intersect(shp.BottomRightCell.Cells, .Range("A1:H100").Cells) Is Nothing Then Sub kh_shp_Delete() Dim R As Integer Dim shp As Shape With Cells.Worksheet For Each shp In .Shapes If Not Intersect(shp.BottomRightCell.Cells, .Range("A1:H100").Cells) Is Nothing Then shp.Delete End If Next shp End With End Sub المرفق 2003 حذف اشكال تلقائية والصور والنماذج في نطاق معين.rar

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

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته فورم للبحث في القرءان الكريم هدية للاخ / سيف الدين خاصة ويعتبر مساهمة مني في ملفه الرائع جزاه الله الف خير ودمتم في حفظ الله وسلامته تحياتي وسلامي اخوكم/ خبور Quran2.rar

السلام عليكم بارك الله فيك استاذ يحياوي كود جميل استاذ محمد صالح تشكر على هذا الشرح المفيد وفقكم الله نستثمر هذا الكود لعملية بسيطه وهو طلب لاحد الأعضاء على انه اذا فتح الملف في الكمبيوتر أول مرة يظهر رسالة وأما اذا فتح مسبقاً لاتظهر الرسالة بيكون الكود هكذا Private Sub Workbook_Open() Dim Counter As Long, LastOpen As String, Msg As String Counter = GetSetting("yah", "med", "العدد", 0) LastOpen = GetSetting("yah", "med", "الفتح", "") Counter = Counter + 1 LastOpen = Date & " " & Time SaveSetting "yah", "med", "العدد", Counter SaveSetting "yah", "med", "الفتح", LastOpen If Val(Counter) = 0 Then MsgBox "أهلا وسهلا", vbInformation, "منتدى أوفسينا" Else Exit Sub End If End Sub

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

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