البحث في الموقع

سلام عليكم جميعا حاولة تعديل في الكود بس مب عارف اصحح الكود الرابط للتــحـــميـــل

الساام عليكم ورحمة الله الاخوة الافاضل عندي هذا الكود في احد ملفات عملي معدل حسب طلبي و هو للاستاذنا الكبير وهرم من اهرام افيسنا سليم حاصبيا في احدى مشاركاتي الكود Dim x as string X= imputbox("اكتب رقم جديد") Range("a2") .select Range("a1:f20").select Selection.copy Sheets.add.name = x range("a1:f20").select Activesheet.paste Application.cutcopymod.false المطلوب هنا هو تعديل بسيط من فظلكم اريد ازالة imputbox واضافةtextbox2 مكانه ويعطي نفس النتيجة يعني الخلية اسم الشيت يساوي القيمة في 2text box جزاكم الله خيرا

اريد اجراء تعديل على الكود لاضافة صفحة اخرى او انشاء كود اخر يضيف صفحة باسم تقرير انظر المرفق ملاحظة : الكود الموجود في هذا الملف للاستاذ الكبير سليم حاصبيا الترحيل حسب الموقعsalim3.rar

Private Sub OptionButton1_Click() With Me If .CheckBox1.Value And .CheckBox2.Value And .CheckBox3.Value = False Then MsgBox "ÇÎÊÇÑ ãÇÈíä ÇáÞíãÉ ÇáäÞÏíÉ Çæ äÓÈÉ ãÆæíÉ" If .CheckBox1.Value And .CheckBox2.Value And .CheckBox3.Value = True Then Sheets("Aldata").Select Range("U2").Select ActiveCell.FormulaR1C1 = "ÇáÕäÝ" If OptionButton1.Value = True Then OptionButton2.Value = False OptionButton3.Value = False OptionButton4.Value = False OptionButton5.Value = False OptionButton6.Value = False 'OptionButton7.Value = False 'OptionButton8.Value = False On Error Resume Next Dim data As Range Dim group1 As Collection Set group1 = New Collection For Each data In add.Range("F6:F" & add.Cells(Rows.Count, "F").End(xlUp).Row) group1.add data, data.Text Next data With Me.ComboBox1 .Clear For i = 1 To group1.Count If group1(i) <> "" Then .AddItem group1(i) End If Next i End With End If Else End Sub يوجد خطأ علي ماعتقد في ترتيب الشروط المطلوب اجبار المستخدم علي اختيار امر من 3 اوامر CheckBox1 او CheckBox2 او CheckBox3 وجزاكم الله خيرا

السلام عليكم ورحمة الله تعالي وبركاته الاخوة الافاضل محتاجة مساعدة من حضراتكم اولا في الفورم مفتاح اسمه اضافه اريد اسم المفتاح يتغير كما موضح بالملف المرفق ( اضافه ) ( اظهار ) في الملف يوزر فورم به عدد 5 TextBox TextBox1 يتم كتابة الاسم به ومع الضغط علي اضافه يتم اضافة الاسم في الخليه ( A1 ) TextBox2 يتم استدعاء البيانات الموجوده في الخلية (A2 ) TextBox3 يتم استدعاء البيانات الموجوده في الخلية (A3 ) TextBox4 يتم استدعاء البيانات الموجوده في الخلية (A4 ) TextBox5 يتم استدعاء البيانات الموجوده في الخلية (A5 ) مرفق ملف للعمل عليه اضافة واستعلام.rar

اريد المساعدت في تعديل اكواد في اكسيل تم ا ستعمال الكود من اكسيل اخر في الاكسيل تم تصميمه... اريد ان اعتدل الكود حتى يصبح يعمل بشكل جيد . اريد ان اعمل فورم اضافة في داتا 2 وعمل فورم تنقل بين السجلات في شيت داتا 1 وشكرا الرجاء المسساعدت في تعديل غلى الكود وشكرأ ...... تم رفع الكسيل للتعديل EXAMPLE1.zip

اساتذتي الكرام سؤال بسيط ماهو سبب هذاالخطأ الموجود بالرسالة المرفقة untitled.bmp

تم إضافة السطرين التاليين في الكود لتسريعه 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

السلام عليكم ورحمة الله وبركاته هل بالامكان تغير الكود ليقوم بحفظ الملف باسم السنة الحالية والشهر السابق ولكم الشكر والتقدير