يوسف عطا

Option Explicit Public Const vArabic As Byte = 1 Public Const vEnglish As Byte = 2 Public Const vMale As Byte = 0 Public Const vFemale As Byte = 1 Private Function myNz(ByVal InValue, Optional ByVal ValueIfNull = Null) myNz = IIf(IsNull(InValue), IIf(IsNull(ValueIfNull), Empty, ValueIfNull), InValue) End Function Private Function Delete(S As String, Index As Integer, Count As Integer) As String Delete = Left(S, Index - 1) + _ Mid(S, Index + Count, Len(S)) End Function Private Function Insert(Source, S As String, Index As Integer) As String Dim LPart As String Dim RPart As String LPart = Left(S, Index - 1) RPart = Mid(S, Index, Len(S)) Insert = LPart & Source & RPart End Function Private Function AddAnd(s1 As String, S2 As String, S3 As String, _ And_ As String, Lang As Byte) As String Dim InAnd_ As String Dim CollectS As String If Lang = vArabic Then InAnd_ = " " + And_ Else InAnd_ = And_ + " " If (s1 <> "") And (S2 <> "") Then And_ = InAnd_ Else And_ = "" CollectS = s1 + And_ + S2 If (CollectS <> "") And (S3 <> "") Then And_ = InAnd_ Else And_ = "" AddAnd = CollectS + And_ + S3 End Function Private Function S2Double(Single_ As Variant, Sex As Byte) As String Dim LLeter As Integer Dim K As Byte Dim Sngl_1 As String Dim Sngl_2 As String K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Sngl_2 = Left(Sngl_2, Len(Sngl_2) - 1) & "تان" Else Sngl_2 = Sngl_2 & "ان" End If End If If Sngl_1 <> "" Then LLeter = Asc(Right(Sngl_1, 1)) Select Case LLeter Case 201 ' "ة" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "تان" Case 236 ' "ى" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "يان" Case 199 ' "ا" Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان" Case 193 ' "ء" If Right(Sngl_1, 2) = "اء" Then If Sex = 1 Then Sngl_1 = Left(Sngl_1, Len(Sngl_1) - 1) & "وان" Else Sngl_1 = Sngl_1 & "ان" End If End If Case Else If Sngl_1 <> "" Then Sngl_1 = Sngl_1 & "ان" End Select If Sngl_2 <> "" Then S2Double = Sngl_1 & " " & Sngl_2 Else S2Double = Sngl_1 End If End Function Private Function Fmale(Num As Byte, Sex As Byte, Female()) As String Dim Two(1 To 4) As String Dim InSex As Byte Two(1) = "أحد" Two(2) = "اثنان" Two(3) = "إحدى" Two(4) = "ة" Select Case Sex Case vMale: Select Case Num Case 1: Fmale = Mid(Female(1), 1, 4) Case 2: Fmale = Two(2) Case 8: Fmale = Female(Num) + "ي" + Two(4) Case 3 To 7, 9, 10: Fmale = Female(Num) + Two(4) Case 11: Fmale = Two(1) + " " + Female(10) Case 12: Fmale = Mid(Two(2), 1, 4) + " " + Female(10) Case 13 To 19: Fmale = Female(Num - 10) + Two(4) + " " + Female(10) End Select Case vFemale: Select Case Num Case 1 To 10: Fmale = Female(Num) Case 11: Fmale = Two(3) + " " + Female(10) + Two(4) Case 12: Fmale = Mid(Female(2), 1, 5) + " " + Female(10) + Two(4) Case 13 To 19: Fmale = Female(Num - 10) + " " + Female(10) + Two(4) End Select End Select End Function Private Function Tens(Num As Byte, Female()) As String Const Noon = "ون" Select Case Num Case 2: Tens = Female(10) + Noon Case 3 To 9: Tens = Female(Num) + Noon End Select End Function Private Function Hunds(Num As Byte, Female()) As String Const Hund = "مائة" Select Case Num Case 1: Hunds = Hund Case 2: Hunds = Mid(Hund, 1, 3) + Mid(Female(2), 4, 3) Case 3 To 9: Hunds = Female(Num) + Hund End Select End Function Private Function Tenteen(Num As Byte, ETens()) As String Const een = "een" Num = Num Mod 10 Select Case Num Case 3 To 9: Tenteen = Mid(ETens(Num), 1, Len(ETens(Num)) - 1) + een End Select End Function Private Function EHunds(Num As Byte, ESingle()) As String EHunds = ESingle(Num) + " hundred" End Function Private Function ReFormat(InNum As Double, Dec As Byte) As Double Dim NewFormat As String If Dec > 0 Then NewFormat = "0." Else NewFormat = "0" NewFormat = NewFormat & String(Dec, "0") ReFormat = Format(InNum, NewFormat) End Function Private Function ReStr(InNum As String) As String Dim K As Byte Dim Digits As Byte Dim Num_ As String Num_ = LTrim(InNum) K = InStr(1, Num_, "E+", 1) If K > 0 Then Digits = Val(Mid(Num_, K + 2, 3)) Num_ = Left(Num_, K - 1) Num_ = Delete(Num_, 2, 1) Do While Len(Num_) - 1 < Digits Num_ = Insert(Num_, "0", 1) Loop End If ReStr = Num_ End Function Private Function AOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Sex As Byte, Dec As Byte) As String Const And_ As String * 1 = "و" Const Lang = vArabic Dim PartNum(0 To 5) As Long Dim Result1(0 To 5) As String Dim Parts_(0 To 11) As String Dim Female(1 To 10) As Variant Dim TempI As Byte Dim Sex2 As Byte Dim K As Byte Dim Only_ As String Dim OnlyPart As String Dim Part_ As String Dim TempS As String Dim Sngl_1 As String Dim Sngl_2 As String Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then AOnly = RTrim("صفر " & Single_) Else AOnly = FracS & " " & Single_ End If Exit Function End If Female(1) = "واحدة" Female(2) = "اثنتان" Female(3) = "ثلاث" Female(4) = "أربع" Female(5) = "خمس" Female(6) = "ست" Female(7) = "سبع" Female(8) = "ثمان" Female(9) = "تسع" Female(10) = "عشر" Parts_(0) = "" Parts_(1) = "ألف" Parts_(2) = "مليون" Parts_(3) = "مليار" Parts_(4) = "ترليون" Parts_(5) = "كدرليون" Parts_(6) = "" Parts_(7) = "آلاف" Parts_(8) = "ملايين" Parts_(9) = "مليارات" Parts_(10) = "ترليونات" Parts_(11) = "كدرليونات" K = InStr(1, Single_ & " ", " ") Sngl_1 = Left(Single_, K - 1) Sngl_2 = "" If K < Len(Single_) Then Sngl_2 = Mid(Single_, K + 1, Len(Single_)) End If For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K Sex2 = Sex For K = 0 To (Parts - 1) If K = (Parts - 1) Then Sex = Sex2 Else Sex = vMale TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = Hunds(CByte(N1), Female()) If PartNum(K) = 200 Then N1_ = Mid(N1_, 1, Len(N1_) - 1) Select Case TempI Case 1 To 2: If K = Parts - 1 Then If FracS <> "" Then N3_ = Fmale(N3, CByte(Sex), Female()) 'Sex Case 3 To 19: N3_ = Fmale(TempI, CByte(Sex), Female()) Case 20 To 99: N2_ = Tens(CByte(N2), Female()) If N3 > 0 Then N3_ = Fmale(N3, CByte(Sex), Female()) If (N3 Mod 10 = 1) And (Sex = vFemale) Then N3_ = "إحدى" End Select OnlyPart = AddAnd(N1_, N3_, N2_, And_, Lang) '{------------------------------------------} If PartNum(K) > 100 Then Select Case TempI Case 1, 2: OnlyPart = AddAnd(OnlyPart, Parts_(Parts - K - 1), "", "", Lang) End Select End If '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = Parts_(Parts - K - 1) If Part_ <> "" Then Select Case TempI Case 2: Part_ = Part_ + "ان" Case 3 To 10: Part_ = Parts_((Parts - K - 1) + 6) Case 11 To 99: Part_ = Part_ + "ا" End Select End If End If '{------------------------------------------} If Part_ <> "" Then If TempI >= 1 And TempI <= 2 Then OnlyPart = AddAnd(OnlyPart, Part_, "", And_, Lang) Else OnlyPart = AddAnd(OnlyPart, Part_, "", "", Lang) End If End If Result1(K) = (OnlyPart) Next K '{------------------------------------------} N1_ = AddAnd(Result1(0), Result1(1), Result1(2), And_, Lang) N2_ = AddAnd(Result1(3), Result1(4), Result1(5), And_, Lang) Only_ = AddAnd(N1_, N2_, "", And_, Lang) If FracS <> "" Then If Only_ <> "" Then FracS = " " + FracS Only_ = AddAnd(Only_, FracS, "", And_, Lang) End If If Only_ <> "" Then If Mid(Only_, Len(Only_), 1) = "ا" Then If Mid(Only_, Len(Only_) - 1, 2) <> "تا" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If If TempS = "000" Then If Mid(Only_, Len(Only_) - 1, 2) = "ان" Then Only_ = Mid(Only_, 1, Len(Only_) - 1) End If End If End If '{------------------------------------------} If FracS = "" Then Select Case TempI Case 0: If Only_ <> "" Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Case 1: Only_ = AddAnd(Only_, AddAnd(Single_, Fmale(1, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 2: Only_ = AddAnd(Only_, AddAnd(S2Double(Single_, CByte(Sex)), Fmale(2, CByte(Sex), Female()), "", "", Lang), "", And_, Lang) Case 3 To 10: If Sngl_2 <> "" Then If Right(Sngl_2, 1) = "ة" Then Only_ = AddAnd(Only_, Plural, Sngl_2, "", Lang) Else Only_ = AddAnd(Only_, Plural, Sngl_2 & "ة", "", Lang) End If Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If Case 11 To 99: If Sngl_1 <> "" Then Only_ = AddAnd(Only_, Sngl_1, "", "", Lang) N1_ = Mid(Only_, Len(Only_), 1) Select Case N1_ Case "ة", "ى", "ا" Case Else Only_ = Only_ + "ا" End Select N1_ = Mid(Only_, Len(Only_) - 2, 3) 'هذا الشرط لحل مشكلة عدم التمييز بين "ء" و "ل" 2002/08/24 If N1_ = "اءا" And Asc(Right(Sngl_1, 1)) = 193 Then Only_ = Left(Only_, Len(Only_) - 1) End If If Sngl_2 <> "" Then If Right(Only_, 1) = "ا" Then Only_ = AddAnd(Only_, Sngl_2 & "ا", "", "", Lang) Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If Else Only_ = AddAnd(Only_, Sngl_2, "", "", Lang) End If End If End Select Else Only_ = AddAnd(Only_, Sngl_1, Sngl_2, "", Lang) End If AOnly = (Only_) End Function Private Function EOnly(Num_ As String, FracS As String, Single_ As String, _ Plural As String, Parts As Byte, Dec As Byte) As String Const Lang = vEnglish Dim ESingle(1 To 12) As Variant Dim ETens(2 To 9) As Variant Dim EParts_(0 To 5) As String Dim PartNum(0 To 5) As Long Dim Result1(0 To 5) As String Dim TempS As String Dim TempI As Byte Dim Sex2 As Byte Dim OnlyPart As String Dim Part_ As String Dim Only_ As String Dim Leng As Integer Dim K As Integer Dim N1 As Byte, N2 As Byte, N3 As Byte Dim N1_ As String, N2_ As String, N3_ As String If Val(Num_) = 0 Then If FracS = "" Then 'EOnly = LTrim(Single_ & " zero") EOnly = RTrim("zero " & Single_) Else EOnly = Single_ & " " & FracS End If Exit Function End If ESingle(1) = "one" ESingle(2) = "two" ESingle(3) = "three" ESingle(4) = "four" ESingle(5) = "five" ESingle(6) = "six" ESingle(7) = "seven" ESingle(8) = "eight" ESingle(9) = "nine" ESingle(10) = "ten" ESingle(11) = "eleven" ESingle(12) = "twelve" ETens(2) = "twenty" ETens(3) = "thirty" ETens(4) = "forty" ETens(5) = "fifty" ETens(6) = "sixty" ETens(7) = "seventy" ETens(8) = "eighty" ETens(9) = "ninety" EParts_(0) = "" EParts_(1) = "thousund" EParts_(2) = "million" EParts_(3) = "billion" EParts_(4) = "trillion" EParts_(5) = "quadrillion" For K = 0 To Parts - 1 PartNum(K) = Val(Mid(Num_, (K * 3) + 1, 3)) Next K For K = 0 To (Parts - 1) TempS = Mid(Num_, (K * 3) + 1, 3) TempI = Val(Mid(TempS, 2, 2)) N1 = Val(Mid(TempS, 1, 1)) N2 = Val(Mid(TempS, 2, 1)) N3 = Val(Mid(TempS, 3, 1)) '{------------------------------------------} N1_ = "": N2_ = "": N3_ = "" If N1 > 0 Then N1_ = EHunds(CByte(N1), ESingle()) Select Case TempI Case 1 To 12: N3_ = ESingle(TempI) Case 13 To 19: If N3 > 0 Then N3_ = Tenteen(CByte(TempI), ETens()) Case 20 To 99: N2_ = ETens(N2) If N3 > 0 Then N3_ = N2_ + "-" + ESingle(N3) N2_ = "" End If End Select OnlyPart = AddAnd(N1_, N2_, N3_, "", Lang) '{------------------------------------------} Part_ = "" If PartNum(K) > 0 Then Part_ = EParts_(Parts - K - 1) If Part_ <> "" Then Part_ = EParts_((Parts - K - 1)) End If Result1(K) = AddAnd(OnlyPart, Part_, "", "", Lang) Next K '{------------------------------------------} N1_ = AddAnd(Result1(0), Result1(1), Result1(2), "", Lang) N2_ = AddAnd(Result1(3), Result1(4), Result1(5), "", Lang) Only_ = AddAnd(N1_, N2_, "", "", Lang) Leng = Len(Only_) Only_ = AddAnd(Only_, FracS, "", " and", Lang) If Only_ <> "" Then 'Only_ = AddAnd(Single_, Only_, "", "", Lang) If Val(Num_) = 1 Then Only_ = AddAnd(Only_, Single_, "", "", Lang) Else Only_ = AddAnd(Only_, Plural, "", "", Lang) End If EOnly = Only_ End If End Function Private Function S_Only(InNum As Variant, Lang As Byte, FracType As Byte) As Variant Dim Num_ As String Dim K As Byte Dim Dec As Byte Dim FType As Byte If IsNull(InNum) Then S_Only = Null Exit Function End If Num_ = Str(InNum) K = InStr(1, Num_, ".", 1) If K > 0 Then Dec = Len(Num_) - K If Dec < 2 Then Dec = 2 Else Dec = 0 End If FType = FracType If FType <> 2 Then FType = 1 S_Only = B_Only(InNum, Lang, 0, Dec, "", "", 0, "", "", FType) End Function Private Function B_Only(InNum As Variant, Lang As Byte, Sex As Byte, Dec As Byte, _ Single_ As String, Plural As String, _ FSex As Byte, SFrac As String, PFrac As String, _ FracType As Byte) As Variant Dim Leng As Byte Dim Parts As Byte Dim K As Byte Dim FracVal As Double Dim Num_ As String Dim FracS As String Dim FracNum As String Dim Only As String Dim And_ As String If IsNull(InNum) Then B_Only = Null Exit Function End If Num_ = Str(InNum) If InStr(1, Num_, "E+", 1) > 0 Then Num_ = ReStr(Num_) FracVal = 0 GoTo DoProcess End If Num_ = ReFormat(Val(InNum), Dec) K = InStr(1, Num_, ".", 1) If K > 0 Then FracS = "0" & Mid(Num_, K, Dec + 1) Else FracS = "" FracVal = Val(FracS) Num_ = Trim(Str(Fix(InNum))) Do While Len(FracS) < Dec + 2 FracS = Insert(FracS, "0", 1) Loop DoProcess: If FracVal = 0 Then FracS = "" FracNum = Trim(Mid(FracS, 3, Len(FracS))) If FracS <> "" Then Select Case FracType Case 2 Select Case Lang Case vArabic: FracS = "1" & String(Dec, "0") & "/" & CDbl(Format(FracNum, String(Dec, "0"))) Case vEnglish: FracS = CDbl(Format(FracNum, String(Dec, "0"))) & "/" & "1" & String(Dec, "0") End Select Case 3 FracS = CLng(FracNum) & " " & SFrac 'If Lang = vEnglish And CDbl(FracNum) > 1 Then FracS = FracS & "(s)" Case 4 Leng = Len(FracNum) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng FracNum = Insert("0", FracNum, 1) Next K Select Case Lang Case vArabic: FracS = AOnly(FracNum, "", SFrac, PFrac, Parts, FSex, FracType) Case vEnglish: 'FracS = EOnly(FracNum, "", "", "", Parts, 0) & " " & SFrac FracS = EOnly(FracNum, "", SFrac, PFrac, Parts, 0) '& " " & SFrac 'If CDbl(FracNum) > 1 Then FracS = FracS & "(s)" End Select End Select End If Leng = Len(Num_) Parts = Fix((Leng + 2) / 3) For K = 1 To (Parts * 3) - Leng Num_ = Insert("0", Num_, 1) Next K If Len(Num_) > 18 Then B_Only = InNum Exit Function End If Select Case FracType Case 1, 2 Select Case Lang Case vArabic: Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, Dec) Case vEnglish: Only = EOnly(Num_, FracS, Single_, Plural, Parts, Dec) End Select Case 3, 4 Select Case Lang Case vArabic: Only = AOnly(Num_, "", Single_, Plural, Parts, Sex, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracType = 3 Then And_ = "و " Else And_ = "و" If FracS <> "" Then Only = AddAnd(Only, FracS, "", And_, CByte(Lang)) Case vEnglish: Only = EOnly(Num_, "", Single_, Plural, Parts, Dec) If CDbl(Num_) = 0 And FracS <> "" Then Only = "" If FracS <> "" Then Only = AddAnd(Only, FracS, "", " and", CByte(Lang)) End Select End Select If Only <> "" Then Select Case Lang 'Case vArabic: B_Only = "فقط " & Only Case vArabic: B_Only = Only & " فقط" 'Case vEnglish: B_Only = Only & " only" Case vEnglish: B_Only = "Only " & Only End Select End If End Function Function ArbNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = Null, _ Optional ByVal FractionType = 1, _ Optional ByVal CurrencySingle = "", _ Optional ByVal CurrencyPlural = "", _ Optional ByVal CurrencySex = 0, _ Optional ByVal FractionSingle = "", _ Optional ByVal FractionPlural = "", _ Optional ByVal FractionSex = 0) As Variant Dim Negative As String If IsNull(InNum) Then ArbNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "سالب " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencySingle) = Empty Or myNz(CurrencyPlural) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces)) End If ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 3 If InNum <> Fix(InNum) Then If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If ArbNum2Text = Negative & _ B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) '-- تعديل خاص لأحد أعضاء منتدى أوفيسنا --------------------------------- If CStr(myNz(CurrencySingle)) = "درجة" And _ CStr(myNz(FractionSingle)) = "جزء" Then Dim Grade As String Dim FracS As String Dim Pos As Integer Grade = Negative & _ B_Only(CDbl(myNz(InNum)), vArabic, CByte(myNz(CurrencySex)), _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), CByte(myNz(FractionSex)), _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))) Select Case CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) Case 0: Case 0.25: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ربع درجة فقط", "ربع فقط") Case 0.5: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "نصف درجة فقط", "نصف فقط") Case 0.75: FracS = IIf(Fix(CDbl(myNz(InNum))) = 0, "ثلاثة أرباع درجة فقط", "ثلاثة أرباع فقط") Case Else: FracS = " " & CDbl(myNz(InNum)) - Fix(CDbl(myNz(InNum))) & " فقط" End Select If FracS <> "" Then Pos = InStr(1, Grade, " و ") If Pos > 0 Then Grade = Left(Grade, Pos + 1) & FracS Else Grade = FracS End If End If Pos = InStr(1, Grade, "درجة واحدة") If Pos > 0 Then Grade = Left(Grade, Pos + 4) & Mid(Grade, Pos + 11) Pos = InStr(1, Grade, "درجتان اثنتان") If Pos > 0 Then Grade = Left(Grade, Pos + 6) & Mid(Grade, Pos + 14) If CDbl(myNz(InNum)) = 0 Then Grade = "صفر" ArbNum2Text = Grade End If '-- نهاية التعديل ------------------------------------------------------- End Function Function EngNum2Text(ByVal InNum, _ Optional ByVal DecimalPlaces = Null, _ Optional ByVal FractionType = 1, _ Optional ByVal CurrencySingle = "", _ Optional ByVal CurrencyPlural = "", _ Optional ByVal FractionSingle = "", _ Optional ByVal FractionPlural = "") As Variant Dim Negative As String If IsNull(InNum) Then EngNum2Text = Null Exit Function Else If InNum < 0 Then InNum = Abs(InNum) Negative = "Negative only " Else Negative = "Only " End If End If If IsNull(FractionType) Then FractionType = 1 If myNz(CurrencyPlural) = Empty Then CurrencyPlural = CurrencySingle '& "(s)" If myNz(FractionPlural) = Empty Then FractionPlural = FractionSingle '& "(s)" If myNz(CurrencySingle) = Empty Then If Not IsNull(DecimalPlaces) Then InNum = ReFormat(CDbl(InNum), CByte(DecimalPlaces)) End If EngNum2Text = Negative & S_Only(InNum, vEnglish, CByte(FractionType)) Exit Function End If If IsNull(DecimalPlaces) Then DecimalPlaces = 3 If InNum <> Fix(InNum) Then If myNz(FractionSingle) = Empty Then If FractionType > 2 Then FractionType = 1 End If End If EngNum2Text = Negative & Mid( _ B_Only(CDbl(myNz(InNum)), vEnglish, 0, _ CByte(myNz(DecimalPlaces)), CStr(myNz(CurrencySingle)), _ CStr(myNz(CurrencyPlural)), 0, _ CStr(myNz(FractionSingle)), CStr(myNz(FractionPlural)), _ CByte(myNz(FractionType))), 6) End Function

أخي يوسف كل سنة و انت بكل خير و سعادة وراحة بال بالنسبة لشكل الشيت الورقي لم يرد لنا أي تعديل و أعتقد إنه مش ها يكون فيه تغيير عن السنة الماضية أما بالنسبة لطلبك بزيادة عدد الطلاب ل 1500 فهناك ملاحظة هامة و هي إن حجم الشيت سيتضاعف لأني بدأت في تلبية طلبك بالأمس و لسة لم أكمل بقية الشيت و وجدت حجمه أصبح 35 ميجا أتوقع بالشكل ده لما أخلصه يوصل 50 ميجا مثلاً !!! و ده حجم ضخم بالنسبة لملف إكسيل !!! مش عارف أكمل الملف و اللا ما أكملوش ؟ أنا كانت عندي فكرة عايز أنفذها و هي بناء الشيت على ملف الجدول الآلي للحصص للأستاذ خبور خير أكرمه الله بس ها تاخد مني وقت شوية و لا أعتقد أنني أستطيع الانتهاء منه قبل شهر مثلاً لأن خبرتي في الأكواد لا تساوي - بل لا تقارب - خبرة أساتذتنا في المنتدى طبعاً و لذلك لابد من العمل بحذر و تأني حتى لا يحدث خطأ لا أستطيع تداركه أعتقد والحال هكذا ألا تتعب نفسك فى هذا الملف ذو ال50 ميجا وأعتذر لو تعبتك معايا لكن إضافة اللغة الفرنسية أمر ضرورى فى التعديلات على الملف الحالى شاكر لك إهتمامك وربنا يوفقك

الله ينور

الف شكر

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

الله ينور عليك يا عمو جمال

الله ينور على جميعكم والشكر موصول لأخونا بن علية

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

الجزء الثالث جمال الفار.part3.rar

الجزء الثانى جمال الفار.part2.rar

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

الف شكر أخى الغالى عبدالله كل عام وأنتم بخير

الكود التالى للأستاذ الكبير الخبير عميد قسم الإيكسيل الذى ننتظر بفارغ الصبر أن يعود سريعاً ليمتعنا بأعماله الرائعة طبعاً تعرفونه دون ذكر إسمه إنه أستاذنا المبدع خبور خير الرجاء شرح ميسر للكود مع توضيح ما الذى ينبغى على تغييره فى الكود لاستطيع تطبيقه فى أعمال متنوعة خاصة كيف أحدد العمود فى الشيت الرئيسى الذى سيحتوى على الكلمات التى بناء عليها سيقوم الكود بالترحيل إلى الشيتات الأخرى Sub Khboor_Tarheel() '============================================= ' الية الكود بعد الترحيل يقوم بمسح البيانات التي تم ترحيلها On Error Resume Next Application.ScreenUpdating = False For a = 2 To [a200].End(xlUp).Row If Cells(a, 1) <> "" Then MySheets = Cells(a, 1) With Sheets(MySheets).[a200].End(xlUp) .Offset(1, 0) = Cells(a, 1) .Offset(1, 1) = Cells(a, 2) .Offset(1, 2) = Cells(a, 3) .Offset(1, 3) = Cells(a, 4) End With End If ' If Sheets("ورقة1").Cells(a, "a") > "" Then Cells(a, 3).Resize(1, 4).Value = "" ' اذا اردت مسح البيانات بعد الترحيل حفز هذا السطر Next a Application.ScreenUpdating = True MsgBox "!تم الترحيل بنجاح", vbInformation + vbMsgBoxRight, "تم الترحيل" Range("a2").Select On Error Resume Next On Error GoTo 0 End Sub

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

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

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

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

مرفوع للأخ جمال الفار عن نفسى حاولت ولم أستطع إنجاز المطلوب

حاضر إنت تؤمر جارى إعداد الملف

أفكار جميلة الف شكر لكل من ساهم فى هذا الموضوع

الف مبروك على ما وهبك الله الف حمدالله على سلامة المدام وندعو للأم والطفل بالصحة والسلامة وتتربى فى عزك

جمال باشا الكود مية مية كيف يمكن وضع أرقام الصفحات فى راس الصفحة ؟؟ علماً بأننى عدلت مكان الخلايا كما يلى Private Sub Workbook_BeforePrint(Cancel As Boolean) With ActiveSheet.PageSetup .RightHeader = Sheets(2).Range("A1").Value .CenterHeader = Sheets(2).Range("B1").Value .LeftHeader = Sheets(2).Range("C1").Value .RightFooter = Sheets(2).Range("A2").Value .CenterFooter = Sheets(2).Range("B2").Value .LeftFooter = Sheets(2).Range("C2").Value End With End Sub

الرجاء متابعة الموضوع التالى وإن شاء الله ستجد فيه الحل تمت التجربة http://www.officena.net/ib/index.php?showtopic=39012

الله ينور عليك يا جمال باشا كود جميل جدا وهو المطلوب بالفعل المهم أن يستوعب كل ما نريد كتابته فى الرأس و التزييل الف شكر

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