اذهب الي المحتوي
أوفيسنا

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


إذهب إلى أفضل إجابة Solved by الخالدي,

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

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

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

رابط هذا التعليق
شارك

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

جزاك الله خير

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

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

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

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

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

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

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

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

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

والله أعلم

رابط هذا التعليق
شارك

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

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

والله أعلم

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

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

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

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

بمعنى

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

رابط هذا التعليق
شارك

  • 1 year later...

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

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

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

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

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

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

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

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

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

If C = 0 Then End

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

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

والله اعلم

في امان الله

  • Like 2
رابط هذا التعليق
شارك

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

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

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

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

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

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

  • Like 1
رابط هذا التعليق
شارك

زائر
هذا الموضوع مغلق.
×
×
  • اضف...

Important Information