كود تفقيط درجات الطلاب ولا أروع

rofa97 · أبريل 12, 2017

بارك الله فيك اخى الكريم

بس يا ريت يكون فى علاج للنصف نريده مكتوب ايضا ( نصف )

احمد الكنزاوي · أغسطس 3, 2018

في ٣٠‏/١٢‏/٢٠١٦ at 20:05, mk_mk_79 said:

اولا اشكرك علي الرد . الملف ممتاز وهذا ما اريده بالضبط . بس لو ممكن نشيل ( 5 ) اللي بتتكتب دي . انا عايز الرقم زي المثل الده بالضبط عند كتابة 150.5 تكتب مائة وخمسون درجة ونصف

في الملف اللي حضرتك بعته عند كتابة 150.5 تكتب هكذا

فقط مائة وخمسون درجةاً و (5) نصف درجة

تفقيط درجات .rar

في ٣‏/٥‏/٢٠١٢ at 09:07, محمدي عبد السميع said:

بسم الله الرحمن الرحيم

الحمد لله الواحد القهار، العزيز الغفار،مكور الليل على النهار ،

تذكرة لأولي القلوب والأبصار وتبصرة لذوي الألباب والاعتبار ،

الذي أيقظ من خلقه من اصطفاه فزهدهم في هذه الدار،

وشغلهم بمراقبته وإدامة الأفكار ،

وملازمة الاتعاظ والادكار،

ووفقهم للدؤوب في طاعته والتأهب لدار القرار،

والحذر مما يسخطه ويوجب دار البوار،

والمحافظة على ذلك مع تغاير الأحوال والأطوار.

أحمده أبلغ حمد وأزكاه، وأشمله وأنماه.

أما بعد:

رأيت أن أقدم عملا خالصا لوجه الله الكريم لعل الله يتغمدنا برحمته

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

ولهذا ساقدم

سلسلة من الأكواد كل كود بعنوان واضح يسهل الوصول له

في موضوع مستقل

وسأشرح كيفية استخدام الكود ماتيسر لي

إن شاء الله

وعلى الله قصد السبيل

******************************************

هذا

كود تفقيط ولاأروع

يصلح لتحويل ارقام المجموع الكلي للطلاب الى تفقيط

ويصلح ايضا لرجال الماهيات

طريقة الاستفادة من الكود

افتح ملف اكسيل

اضغط على الرز ALT وانت ضاغط على الزر

اضغط على F11 الموجود أعلا لوحة المفاتيح

ستظهر شاشة الماكرو

اضغط على موديول 1

سيتم فتح الموديول

الصق فيه الكود الموجود

تحت هذا السطر


'-- Abo Hadi, 28/07/2003 --'

'-- Last update on 28/07/2006

' تم إضافة تشكيل بعض التفقيط الذي يسمح بالتشكيل الثابت

'وتم اضافة الحروف (ء و اء و أ) إلى الحروف التي لا يأتي بعدها ألف التنوين المنصوب

' وتم إضافة كلمة (فقط لا غير ) في آخر التفقيط

'وذلك في 9/8/2007 (يوم ميلادي) محمد صالح

Option Explicit

Public Const vArabic As Byte = 1

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 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 7) As Long

  Dim Result1(0 To 8) As String

  Dim Parts_(0 To 13) 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) = "ترليوناتٍ"

  Parts_(12) = "كدرليوناتٍ"

  Parts_(13) = "كوينتليوناتٍ"

  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 <> "" And InStr(2, Plural, Sngl_2) > 0 Then

	Sngl_2 = ""

  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) + 7)

			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

	'{------------------------------------------}

	For K = 0 To Parts - 1

	  Only_ = AddAnd(Only_, Result1(K), "", And_, Lang)

	Next K

	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 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_ = CStr(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

  If Dec > 6 Then Dec = 6

  Num_ = Format(InNum, "0" & IIf(Dec > 0, ".", "") & String(Dec, "0"))

  If Dec > 0 Then FracS = "0." & Right(Num_, Dec) Else FracS = ""

  If Dec > 0 Then Num_ = Left(Num_, Len(Num_) - Dec - 1)

  FracVal = Val(FracS)

  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")))

	End Select

	  Case 3

		Select Case Lang

		  Case vArabic:  FracS = CLng(FracNum) & " " & IIf(FracNum >= 3 And FracNum <= 10, PFrac, SFrac)

				  End Select

	  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)

				  End Select

	End Select

  End If

  Leng = Len(Num_)

  Parts = Fix((Leng + 2) / 3)

  If Parts > 7 Then

	B_Only = InNum

	Exit Function

  End If

  For K = 1 To (Parts * 3) - Leng

	Num_ = Insert("0", Num_, 1)

  Next K

  Select Case FracType

	Case 1, 2

	  Select Case Lang

		Case vArabic:  Only = AOnly(Num_, FracS, Single_, Plural, Parts, Sex, 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))


	  End Select

  End Select

  If Only <> "" Then

	Select Case Lang

	  Case vArabic:  B_Only = Only

	End Select

  End If

End Function

'يمكنك تغيير كلمة جنيه بأي معدود مفرد وكلمة جنيهات بأي معدود جمع وكذلك الحال مع الكسر وجنس المعدود أو الكسر (0) للمذكر و (1) للمؤنث

' تم إضافة هذه الملاحظات بواسطة محمد صالح حتى يتم استعمالها في الاستعلامات

Function ArbNum2Text(ByVal InNum, _

			Optional ByVal DecimalPlaces = 2, _

			Optional ByVal FractionType = 4, _

			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 = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0"))

	End If

	ArbNum2Text = Negative & S_Only(InNum, vArabic, CByte(FractionType))

	Exit Function

  End If

  If IsNull(DecimalPlaces) Then DecimalPlaces = 2

  InNum = Format(InNum, "0" & IIf(DecimalPlaces > 0, ".", "") & String(DecimalPlaces, "0"))

'If InNum <> Fix(InNum) Then

  If Val(Right(InNum, DecimalPlaces)) > 0 Then

	If myNz(FractionSingle) = Empty Or myNz(FractionPlural) = Empty Then

	  If FractionType > 2 Then FractionType = 1

	End If

  End If

  ' تم إضافة كلمة فقط لا غير في آخر التفقيط بواسطة محمد صالح

   Dim m

   m = " فقطُ لا غيرَ"

  ArbNum2Text = Negative & _

				B_Only(CDec(myNz(InNum, 0)), 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))) & m

End Function[/center]

انتقل الى صفحة الإكسيل

واكتب في الخلية B6 اي رقم مثلا 50

وفي أي خليه أخرى ولتكن الخلية D6 اكتب الجملة التاليه




=ArbNum2Text(B6;1;1;"درجـة";"درجـات";1;"جزء";"أجزاء";1)

اضغط انتر

سيظهر تفقيط الرقم

وإذا أردنا الاستفادة من الكود في الماهيات

نضع في الخليه D6

هذه الجمله




="  فقط "&ArbNum2Text(B6; 2;3;"جنيه";"جنيهات";1;"قرش";"قروش";1)

أو اكتب هذه الجمله




=   "الصافي : " & ArbNum2Text(B6)

ودمتم في حفظ الله

كود تفقيط مفيد باستخدامات مختلفة.rar

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

مثلا

55.542 خمس وخمسون وخمسمائة واثنان واربعون بالالف

86.57 ست وثمانون وسبع وخمسون بالمائة

74.3 اربع وسبعون وثلاث بالعشرة

في ١٧‏/٣‏/٢٠١٣ at 00:54, ضاحي الغريب said:

الاخ الكريم محمد عبدالسميع

طرح جميل وفكرته ايضا سهلة وسلسلة

بارك الله لك وجزاك عنه كل خير وجعله في ميزان حسناتك

تقبل تحياتي

تسجيل الدخول

كود تفقيط درجات الطلاب ولا أروع

الردود الموصى بها

rofa97

احمد الكنزاوي

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information