عدم تفعيل الحساب التلقائي بعد تغيره إلى حساب يدوي في الكود

[الشهابي]

تم إضافة السطرين التاليين في الكود لتسريعه

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManua

ومن ثم في آخره تم إضافة السطرين التاليين لإرجاع اهتزاز الشاشة وإرجاع الحساب تلقائي

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

لكن الحساب بقى يدوي ولم يعد تلقائي طبعا الكود مرتبط بالدالة التالية له والكود هو

Option Explicit

Option Base 1



Sub StudentRank_1()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

'

Dim vArrDgree(100)				 ' المصفوفة  تحتوى على الدرجات

Dim vArrDgreeOk(100, 3)			' المصفوفة التى تحتوى على الترتيب

Dim vStdRange As Range			'النطاق الأصل

Dim vRnkRange As Range			'النطاق الهدف للترتيب الحرفى

Dim vRnkRangeNum As Range		 'النطاق الهدف للترتيب الرقمى

Dim vStdCount					 'عدد الخلايا التى تحتوى على درجات (عدد الطلاب)

Dim vStrtCell					 'الخلية التى سيبدأ عندها الترتيب

Dim vRnkNo As Integer			 'الرقم المراد ترتيبه

Dim vRnkTxt As String			 'الترتيب


Dim N1 As Integer, N2 As Integer, N As Integer	  'لتحديد المتكرر فى المصفوفة

Dim i, C, V, T, x								   'للاستخدام فى عمليات التكرار


'*****************************************************************************************************

'********************														  ***********************

'********************  هنا أهم نقطة حيث يتم تحديد النطاقات التى سيتم العمل عليها ***********************

'********************														  ***********************

'*****************************************************************************************************


Set vStdRange = Worksheets("شعب المسودة").Range("AW16:AW115")

Set vRnkRange = Worksheets("شعب المسودة").Range("AY16:AY115")

Set vRnkRangeNum = Worksheets("شعب المسودة").Range("AZ16:1Z515")


'*****************************************************************************************************

'*****************************************************************************************************

'*****************************************************************************************************




'vStdCount = WorksheetFunction.CountA(vStdRange)			'فى حالة عدم وجود أى قيمة فى الخلية

vStdCount = WorksheetFunction.CountIf(vStdRange, ">0")	  'فى حالة احتواء الخلية على قيم صفرية


For i = 1 To vStdCount

	vArrDgree(i) = WorksheetFunction.Large(vStdRange, i)

Next i

'---------\* Find The position of a value in array

'Range("L4").Value = WorksheetFunction.Match(415, vArrDgree)

'---------/*


vRnkRange.ClearContents

vRnkRangeNum.ClearContents


i = 1								  'The first Cell

T = 0								  ' The number of Repeats

For Each C In vArrDgree

If i = 1 Then

	vArrDgreeOk(i, 1) = C

	vArrDgreeOk(i, 2) = NumRank(i)

	vArrDgreeOk(i, 3) = i

'	vRnkRange.Cells(I) = vArrDgreeOk(I, 2)

'	vRnkRangeNum.Cells(I) = vArrDgreeOk(I, 3)

End If

	If i  1 Then

		If vArrDgree(i) = vArrDgree(i - 1) Then

			T = T + 1

			V = NumRank(i - T) & " م"

			vArrDgreeOk(i, 1) = C

			vArrDgreeOk(i, 2) = V

			vArrDgreeOk(i, 3) = i - T


			vArrDgreeOk(i - 1, 2) = V

			vArrDgreeOk(i - 1, 3) = i - T


'			vRnkRange.Cells(I) = vArrDgreeOk(I, 2)

'			vRnkRangeNum.Cells(I) = vArrDgreeOk(I, 3)


'			vRnkRange.Cells(I - 1) = vArrDgreeOk(I, 2)

'			vRnkRangeNum.Cells(I - 1) = vArrDgreeOk(I, 3)


				 GoTo Nooo

		End If

	If vArrDgree(i) = 0 Then GoTo Ended

	vArrDgreeOk(i, 1) = C

	vArrDgreeOk(i, 2) = NumRank(i - T)

	vArrDgreeOk(i, 3) = i - T


'	vRnkRange.Cells(I) = vArrDgreeOk(I, 2)

'	vRnkRangeNum.Cells(I) = vArrDgreeOk(I, 3)

	End If


Nooo:


	i = i + 1

Next C


Ended:

'---------\* Find The position of a value in array

'Range("N3").Value = WorksheetFunction.Index(vArrDgreeOk, 1, 2)

'---------/*

i = 1

For Each C In vStdRange


'T = C.Address(0, 0)															 ' ---->  B4

T = C.Row																		 ' ---->  4


'vRnkNo = WorksheetFunction.Index(vArrDgreeOk, I, 1) 'Find the Degree			' ---->i=1  415

'vRnkTxt = WorksheetFunction.Index(vArrDgreeOk, I, 2) 'Find the Order			' ---->i=1  الأول


If C = 0 Then End

V = WorksheetFunction.VLookup(C, vArrDgreeOk(), 2, 0)

x = WorksheetFunction.VLookup(C, vArrDgreeOk(), 3, 0)


vRnkRange.Cells(i, 1).Value = V

vRnkRangeNum.Cells(i, 1).Value = x


i = i + 1

Next C

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub

Function NumRank(vNumTxt) As String



'*

'تجهيز مصفوفة من 50 متغير عبارة عن الترتيب المراد إدخاله

Dim vRankTxt(100)

'إسناد المتغيرات للمصفوفة

vRankTxt(1) = "الأول"

vRankTxt(2) = "الثانى"

vRankTxt(3) = "الثالث"

vRankTxt(4) = "الرابع"

vRankTxt(5) = "الخامس"

vRankTxt(6) = "السادس"

vRankTxt(7) = "السابع"

vRankTxt(8) = "الثامن"

vRankTxt(9) = "التاسع"

vRankTxt(10) = "العاشر"

vRankTxt(11) = "الحادى عشر"

vRankTxt(12) = "الثانى عشر"

vRankTxt(13) = "الثالث عشر"

vRankTxt(14) = "الرابع عشر"

vRankTxt(15) = "الخامس عشر"

vRankTxt(16) = "السادس عشر"

vRankTxt(17) = "السابع عشر"

vRankTxt(18) = "الثامن عشر"

vRankTxt(19) = "التاسع عشر"

vRankTxt(20) = "العشرون"

vRankTxt(21) = "الحادى والعشرون"

vRankTxt(22) = "الثانى والعشرون"

vRankTxt(23) = "الثالث والعشرون"

vRankTxt(24) = "الرابع والعشرون"

vRankTxt(25) = "الخامس والعشرون"

vRankTxt(26) = "السادس والعشرون"

vRankTxt(27) = "السابع والعشرون"

vRankTxt(28) = "الثامن والعشرون"

vRankTxt(29) = "التاسع والعشرون"

vRankTxt(30) = "الثلاثون"

vRankTxt(31) = "الحادى والثلاثون"

vRankTxt(32) = "الثانى والثلاثون"

vRankTxt(33) = "الثالث والثلاثون"

vRankTxt(34) = "الرابع والثلاثون"

vRankTxt(35) = "الخامس والثلاثون"

vRankTxt(36) = "السادس والثلاثون"

vRankTxt(37) = "السابع والثلاثون"

vRankTxt(38) = "الثامن والثلاثون"

vRankTxt(39) = "التاسع والثلاثون"

vRankTxt(40) = "الأربعون"

vRankTxt(41) = "الحادى والأربعون"

vRankTxt(42) = "الثانى والأربعون"

vRankTxt(43) = "الثالث والأربعون"

vRankTxt(44) = "الرابع والأربعون"

vRankTxt(45) = "الخامس والأربعون"

vRankTxt(46) = "السادس والأربعون"

vRankTxt(47) = "السابع والأربعون"

vRankTxt(48) = "الثامن والأربعون"

vRankTxt(49) = "التاسع والأربعون"

vRankTxt(50) = "الخمسون"

vRankTxt(51) = "الحادى والخمسون"

vRankTxt(52) = "الثانى والخمسون"

vRankTxt(53) = "الثالث والخمسون"

vRankTxt(54) = "الرابع والخمسون"

vRankTxt(55) = "الخامس والخمسون"

vRankTxt(56) = "السادس والخمسون"

vRankTxt(57) = "السابع والخمسون"

vRankTxt(58) = "الثامن والخمسون"

vRankTxt(59) = "التاسع والخمسون"

vRankTxt(60) = "الستون"

vRankTxt(61) = "الحادى والستون"

vRankTxt(62) = "الثانى والستون"

vRankTxt(63) = "الثالث والستون"

vRankTxt(64) = "الرابع والستون"

vRankTxt(65) = "الخامس والستون"

vRankTxt(66) = "السادس والستون"

vRankTxt(67) = "السابع والستون"

vRankTxt(68) = "الثامن والستون"

vRankTxt(69) = "التاسع والستون"

vRankTxt(70) = "السبعون"

vRankTxt(71) = "الحادى والسبعون"

vRankTxt(72) = "الثانى والسبعون"

vRankTxt(73) = "الثالث والسبعون"

vRankTxt(74) = "الرابع والسبعون"

vRankTxt(75) = "الخامس والسبعون"

vRankTxt(76) = "السادس والسبعون"

vRankTxt(77) = "السابع والسبعون"

vRankTxt(78) = "الثامن والسبعون"

vRankTxt(79) = "التاسع والسبعون"

vRankTxt(80) = "الثمانون"

vRankTxt(81) = "الحادى والثمانون"

vRankTxt(82) = "الثانى والثمانون"

vRankTxt(83) = "الثالث والثمانون"

vRankTxt(84) = "الرابع والثمانون"

vRankTxt(85) = "الخامس والثمانون"

vRankTxt(86) = "السادس والثمانون"

vRankTxt(87) = "السابع والثمانون"

vRankTxt(88) = "الثامن والثمانون"

vRankTxt(89) = "التاسع والثمانون"

vRankTxt(90) = "التسعون"

vRankTxt(91) = "الحادى والتسعون"

vRankTxt(92) = "الثانى والتسعون"

vRankTxt(93) = "الثالث والتسعون"

vRankTxt(94) = "الرابع والتسعون"

vRankTxt(95) = "الخامس والتسعون"

vRankTxt(96) = "السادس والتسعون"

vRankTxt(97) = "السابع والتسعون"

vRankTxt(98) = "الثامن والتسعون"

vRankTxt(99) = "التاسع والتسعون"

vRankTxt(100) = "المائة"



If vNumTxt > 100 Then GoTo NOTHERE

NumRank = vRankTxt(vNumTxt)

NOTHERE:


End Function

[احمدزمان]

السلام عليكم و رحمة الله

جرب

Application.Calculation = xlAutomatic

[الشهابي]

أستاذنا الكبير أحمد زمان

جزاك الله خير

جربت إضافتك ولكن

لم يتم تفعيل الحساب التلقائي

على فكرة قمت بعمل كود تشغيل كودين مع بعض

الكود الأول كود الترتيب السابق

والكود الثاني لجعل الحساب تلقائي

ولكن لم تنجح الطريقة

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

ثم تشغيل الكود الثاني يتم الأمر

على حسب ما أعتقد أن الأمر له علاقة بالدالة المرتبط بها

والله أعلم

[احمدزمان]

ثم تشغيل الكود الثاني يتم الأمر

على حسب ما أعتقد أن الأمر له علاقة بالدالة المرتبط بها

والله أعلم

اخي الحبيب الشهابي

ممكن كما ذكرت الداله لها دور

ممكن تكون الداله المضافة تعطي مرجع معاد

ويكون المرجع المعاد هو السبب

بمعنى

عمليات حسابية بتدخل في دائرة لا نهائية

[الشهابي]

بعد مرور سنتين على الموضوع 

أرفعه مرة أخرى ربما أجد الحل إن شاء الله

وجزاء الله أستاذنا القدير / أحمد يعقوب زمان  خيراً على رده على الموضوع وتعاونه معنا 

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

وسأرفق ملف كمثال به الكود حتى يتم العمل عليه

تحياتي وتقديري لجميع الأعضاء

الصف الخامس.rar

[الخالدي]

السلام عليكم ورحمة الله وبركاته

الاخ الحبيب الشهابي

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

If C = 0 Then End

فاذا تحقق شرط الدالة If في السطر السابق فيتم انهاء الكود بدون تنفيذ الاوامر في الاسطر اللاحقة من الكود بما فيها امر تفعيل الحساب التلقائي

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

والله اعلم

في امان الله

[الشهابي]

أستاذنا العزيز وحبيبنا الغالي ا لأستاذ / الخالدي 

فعلا كلامك مضبوط 100% وقد عدلت السطر  السابق على النحو التالي وكان تماماً

If C = 0 Then Application.Calculation = xlAutomatic: End

أستاذي العزيز على الرغم من قلة تواجدك في المنتدى إلا أنك تبهرنا بردودك الصائبة والمفيدة 

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

تقبل تحياتي وتقديري