عبدالله باقشير

السلام عليكم الشكر واصل للاخ الشهابي كود: Option Explicit '====================================================== '====================================================== ' اسم نطاق رؤوس الاعمدة ' او عنوان رؤوس الاعمدة ملحوقة باسم الورقة Private Const MyTopColmnRng As String = "العمليات!$A$3:$G$3" ' MyTopColmnRng رقم عمود رقم الحساب من النطاق Private Const MyColmnFind As Integer = 2 ' MyTopColmnRng رقم عمود التاريخ من النطاق Private Const dColmn As Integer = 6 '====================================================== '====================================================== Sub kh_ClearContents() Range("B16").Resize(500, 8).ClearContents End Sub Sub kh_Start() Dim MyRng As Range Dim R As Integer Dim ContRow As Integer, i As Integer, ii As Integer Dim tFindNum As String Dim dt1 As Date, dt2 As Date '------------------------- On Error GoTo 1 '------------------------- Set MyRng = Range(MyTopColmnRng) '------------------------- kh_ClearContents '------------------------- With MyRng ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row End With If ContRow = 0 Then Exit Sub '------------------------- ' خلية رقم الحساب المطلوب tFindNum = LCase(Range("C6")) '------------------------- ' خلايا التاريخ dt1 = DateValue(Range("C12")) dt2 = DateValue(Range("I12")) '------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------------- ii = 16 With MyRng.Offset(1, 0) For R = 1 To ContRow Select Case .Cells(R, dColmn).Value2: Case dt1 To dt2 If LCase(.Cells(R, MyColmnFind)) Like tFindNum Then If Val(.Cells(R, 5)) > 0 Then Cells(ii, "B").Value = Val(.Cells(R, 5)) If Val(.Cells(R, 5)) < 0 Then Cells(ii, "C").Value = Abs(.Cells(R, 5)) Cells(ii, "D").Value = Val(Cells(ii - 1, "D")) + Val(.Cells(R, 5)) Cells(ii, "E").Value = .Cells(R, 4).Value Cells(ii, "H").Value = .Cells(R, 1).Value Cells(ii, "I").Value = .Cells(R, 6).Value ii = ii + 1 End If End Select Next End With 1: '------------------------- Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic '------------------------- If Err Then MsgBox "Err.Number : " & Err.Number Else If ii > 16 Then MsgBox "تم الترحيل بنجاح ", vbMsgBoxRight, "الحمدلله" Else MsgBox "لا توجد نتائج للبحث", vbMsgBoxRight, "عفوا" End If End If Set MyRng = Nothing End Sub المرفق 2003 / 2007 العملاء.rar

بداية الكود تجد اعدادات الكود يمكنك التغيير فيها Option Explicit '====================================================== '====================================================== ' اسم نطاق رؤوس الاعمدة ' او عنوان رؤوس الاعمدة ملحوقة باسم الورقة Private Const MyTopColmnRng As String = "بيانات!$A$5:$K$5" ' MyTopColmnRng رقم عمود رقم الحساب من النطاق Private Const MyColmnFind As Integer = 2 ' MyTopColmnRng رقم عمود التاريخ من النطاق Private Const dColmn As Integer = 9 ' MyTopColmnRng عدد الاعمدة المطلوبه من النطاق Private Const ContColmn As Integer = 7 ' ContColmn ارقام الاعمدة المطلوبه من النطاق حسب العدد المطلوب Private Const sColmn As String = "4,6,8,5,9,7,10" '====================================================== '====================================================== Sub kh_ClearContents() Dim P As Integer Dim Adr As String For P = 1 To 3 Adr = Choose(P, "B5", "B47", "B89") Range(Adr).Resize(32, ContColmn).ClearContents Next End Sub Sub kh_Start() Dim MyRng As Range Dim R As Integer, c As Integer Dim ContRow As Integer, i As Integer, ii As Integer, iii As Integer Dim tFindNum As String Dim dt1 As Date, dt2 As Date '------------------------- On Error GoTo 1 '------------------------- Set MyRng = Range(MyTopColmnRng) '------------------------- kh_ClearContents '------------------------- With MyRng ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row End With If ContRow = 0 Then Exit Sub '------------------------- ' خلية رقم الحساب المطلوب tFindNum = LCase(Range("H1")) '------------------------- ' خلايا التاريخ dt1 = DateValue(Range("K1")) dt2 = DateValue(Range("K2")) '------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------------- With MyRng.Offset(1, 0) For R = 1 To ContRow Select Case .Cells(R, dColmn).Value2: Case dt1 To dt2 'ib = LCase(.Cells(R, MyColmnFind)) Like tFindNum If LCase(.Cells(R, MyColmnFind)) Like tFindNum Then ii = ii + 1 For c = 1 To ContColmn i = Split("," & sColmn, ",")(c) Range("B5").Cells(ii, c).Value = .Cells(R, i).Value Next iii = iii + 1 ' اذا وصلت البيانات الى مضاعف 32 تزداد بمقدر 10 If iii Mod 32 = 0 Then ii = ii + 10 End If End Select Next End With 1: '------------------------- Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic '------------------------- If Err Then MsgBox "Err.Number : " & Err.Number Else If iii Then MsgBox "تم الترحيل بنجاح ", vbMsgBoxRight, "الحمدلله" Else MsgBox "لا توجد نتائج للبحث", vbMsgBoxRight, "عفوا" End If End If Set MyRng = Nothing End Sub المرفق 2003/2007 حسابات1.rar

السلام عليكم طبق هذا الكود على ملفك 2007 لانه مغلق Option Explicit '====================================================== '====================================================== ' اسم نطاق رؤوس الاعمدة Private Const MyTopColmnRng As String = "MyRDate" ' رقم عمود رقم الحساب من النطاق Private Const MyColmnFind As Integer = 2 ' رقم عمود التاريخ من النطاق Private Const dColmn As Integer = 9 '====================================================== '====================================================== Sub kh_ClearContents() Range("B4").Resize(33, 7).ClearContents Range("B46").Resize(33, 7).ClearContents Range("B88").Resize(33, 7).ClearContents End Sub Sub kh_Start() Dim ib As Boolean Dim R As Integer, c As Integer Dim i As Integer, ii As Integer, iii As Integer Dim ContRow As Integer Dim dt1 As Date, dt2 As Date '------------------------- kh_ClearContents '------------------------- With Range(MyTopColmnRng) ContRow = .Worksheet.Cells(Rows.Count, .Column).End(xlUp).Row - .Row If ContRow = 0 Then Exit Sub dt1 = DateValue(Range("K1")) dt2 = DateValue(Range("K2")) End With '------------------------- With Range(MyTopColmnRng).Offset(1, 0) Do While R < ContRow: R = R + 1 Select Case .Cells(R, dColmn).Value2: Case dt1 To dt2 ib = LCase(.Cells(R, MyColmnFind)) Like LCase(Range("H1")) If ib Then ii = ii + 1 c = 0 While c < 7: c = c + 1 i = Choose(c, 4, 6, 8, 5, 9, 7, 11) Range("B4").Cells(ii, c).Value = .Cells(R, i).Value Wend iii = iii + 1 If iii Mod 33 = 0 Then ii = ii + 9 End If End Select Loop End With If iii Then MsgBox "تم الترحيل بنجاح ", vbMsgBoxRight, "الحمدلله" Else MsgBox "لا توجد نتائج للبحث", vbMsgBoxRight, "عفوا" End If End Sub المرفق 2003 حسابات1.rar

السلام عليكم استفسار حسب سعة وقتكم ليس عنوان لموضوعك وهذا مخالف لقواعد المشاركة هذه المرة تحذير واخرى سيتم اغلاق او حذف الموضوع ================================== بالنسبة لطلبك هكذا تستخدم الكنترول في بدلالة الاسم Me.Controls("ComboBox" & i) مثال : Private Sub CommandButton1_Click() Dim i As Integer For i = 1 To 8 MsgBox Me.Controls("ComboBox" & i).Value Next i End Sub

شاهد المرفق 2003 المستخدمين1.rar

اكرمك الله اكرام الصالحين ورزقك الفردوس انت واهلك وذويك ومن تحب تقبل تحياتي وشكري

ولك مثله اضعاف مضاعفة في المرفق الاخير تمت تعديلات اخرى ملاحظة : تم تعديل العنوان ليسهل البحث عن الكود تقبل تحياتي وشكري

السلام عليكم Option Explicit ' اسماء المواد Const nTEST As String = "عريى" & "," & _ "رياضيات" & "," & _ "دراسات" & "," & _ "انجليزى" & "," & _ "علوم" & "," & _ "مجموع" & "," & _ "دين" '-------------------------------------- ' ارقام اعمدة الدرجة الاصلية ' بالتسلسل حسب اسماء المواد Const ColmnTotal As String = "26,35,44,53,64,65,82" ' ارقام اعمدة الفصل الثاني ' هنا المجموع ليس له عمود جعلناه صفراً Const ColmnTest2 As String = "22,31,40,49,60,0,78" ' رقم صف النهاية الصغرى Const iRs As Integer = 10 ' اول صف للبيانات Const TopRow As Integer = 11 Sub kh_Tgrba() Dim sCont As Integer, R As Integer Dim Tst As String On Error GoTo 1 '------------------ ' عدد الطلبة ' ممكن يؤخذ من خلية او يكتب كتابة sCont = 500 '--------------------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual '------------------ sCont = sCont + TopRow With ActiveSheet For R = TopRow To sCont If Not IsEmpty(.Cells(R, "C")) Then Tst = kh_Test(R) If Len(Tst) Then .Cells(R, "DI") = "له دور ثانى فى" Else .Cells(R, 113) = "ناجح" .Cells(R, "DJ") = kh_Test(R) End If Next End With 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox "تم اظهار النتيجة بنجاح" End If End Sub Function kh_Test(iRow As Integer) As String Dim vT, sT Dim NN As String, TT As String Dim ctlt As Integer, ctst As Integer Dim c As Integer, cc As Integer Dim ib As Boolean cc = UBound(Split(nTEST, ",")) For c = 0 To cc ib = False NN = Split(nTEST, ",")(c) ctlt = Split(ColmnTotal, ",")(c) ctst = Split(ColmnTest2, ",")(c) vT = Cells(iRow, ctlt) If Not IsEmpty(vT) Then Select Case vT Case Is = "غ", "غـ": ib = True Case Is < Cells(iRs, ctlt): ib = True End Select End If If ctst = 0 Then GoTo 1 sT = Cells(iRow, ctst) If Not IsEmpty(sT) Then Select Case sT Case Is = "غ", "غـ" NN = NN & " لثلث الدرجة": ib = True Case Is < Cells(iRs, ctst) NN = NN & " لثلث الدرجة": ib = True End Select End If 1: If ib Then TT = TT & IIf(Len(TT), " - ", "") & NN Next kh_Test = TT End Function شاهد المرفق 2003 حالة الطاالب.rar

السلام عليكم الاخ الفاضل / elsedik ------------- حفظه الله لقد تم الشرح اعلاه والباقي عبارة عن قيود نقل بيانات بالتساوي بنفس مقاسات الاعمدة والصفوف . Range("B" & ii).Resize(1, 2).Value = Range("B" & r).Resize(1, 2).Value .Range("E" & ii).Resize(1, 4).Value = Range("D" & r).Resize(1, 4).Value الاخ الفاضل / أبو أنس حاجب -----------حفظه الله جزاك الله خيرا وبارك فيك واثابك بدعائك واعطاك بمثله اضعاف مضاعفة تقبلا تحياتي وشكري

اخي وحبيبي في الله رجب حفظه الله A1 هي range صح نحن نعمل معادلة وهمية Evaluate مربوطة باسم الورقة مثلا =Sheet4!$A$1 اذا كان اسم الورقة هذا صحيح نتيجة TypeName range اذا كان غير صحيح Error وبهذ نعرف اسم الورقة هذا صحيح ام لا لان عملية الفحص لاسماء الاوراق بفور نكس لكل قيد وخاصة اذا كان معاك اوراق كثير مرهقة للكود تقبل تحياتي وشكري لحرصك على التعلم

اخي الفاضل حفظك الله انا الذي يجب ان اعتذر منك لاني خربطت في مشاركتك بالخطا عاملا ردي فيها ظنا مني اني اقتبستها فاتضح اني كنت اعدل فيها تقبل اعتذاري :imsorry: :imsorry: :imsorry: تحياتي وشكري

حفظك الله ابو حنين وبارك فيك وجزاك خيرا تقبل تحياتي وشكري

السلام عليكم جرب هذا Sub kh_Trheel() Dim tShName As String Dim sh As Worksheet Dim r%, ii% For r = 8 To 20 tShName = "'" & CStr(Cells(r, 1)) & "'!A1" ' هذا الشرط يعمل اختبار لصحة اسم الورقة If TypeName(Evaluate(tShName)) = "Range" Then Set sh = Sheets(CStr(Cells(r, 1))) With sh ii = .[E1000].End(xlUp).Row + 1 .Range("B" & ii).Resize(1, 2).Value = Range("B" & r).Resize(1, 2).Value .Range("E" & ii).Resize(1, 4).Value = Range("D" & r).Resize(1, 4).Value End With End If Next Set sh = Nothing End Sub

شاهد الرابط التالي http://www.officena.net/ib/index.php?showtopic=25490

السلام عليكم هذه للتجربة ويجب ان تعمل اجماليات لعمود المجموع علشان تجرب الكود كويس الكود يعمل من الصف 11 ال 17 Option Explicit ' اسماء المواد Const nTEST As String = "عريى" & "," & _ "رياضيات" & "," & _ "دراسات" & "," & _ "انجليزى" & "," & _ "علوم" & "," & _ "مجموع" & "," & _ "دين" '-------------------------------------- ' ارقام اعمدة الدرجة الاصلية ' بالتسلسل حسب اسماء المواد Const ColmnTotal As String = "26,35,44,53,64,65,82" ' ارقام اعمدة الفصل الثاني ' هنا المجموع ليس له عمود جعلناه صفراً Const ColmnTest2 As String = "22,31,40,49,60,0,78" ' رقم صف النهاية الصغرى Const iRs As Integer = 10 Sub kh_Tgrba() Dim r As Integer Dim tst As String For r = 11 To 17 tst = kh_test(r) If Len(tst) Then Cells(r, 113) = "له دور ثانى فى" Else Cells(r, 113) = "ناجح" Cells(r, 114) = kh_test(r) Next End Sub Function kh_test(iRow As Integer) As String Dim vT, sT Dim NN As String, TT As String Dim ctlt As Integer, ctst As Integer Dim c As Integer, cc As Integer Dim ib As Boolean cc = UBound(Split(nTEST, ",")) For c = 0 To cc ib = False NN = Split(nTEST, ",")(c) ctlt = Split(ColmnTotal, ",")(c) ctst = Split(ColmnTest2, ",")(c) vT = Cells(iRow, ctlt) If Not IsEmpty(vT) Then Select Case vT Case Is = "غ": ib = True Case Is < Cells(iRs, ctlt): ib = True End Select End If If ctst = 0 Then GoTo 1 sT = Cells(iRow, ctst) If Not IsEmpty(sT) Then Select Case sT Case Is = "غ": ib = True Case Is < Cells(iRs, ctst): ib = True End Select End If 1: If ib Then TT = TT & NN & " - " Next kh_test = TT End Function المرفق 2003 حالة الطاالب.rar

هل تريد تحويل عملها عن طريق كود ؟؟ هذا الذي فهمته ام تريد لصق قيمة المعادلة عن طريق الكود يعني يقوم بتنفيذ المعادلة ثم يبقي قيمتها فقط ؟؟

السلام عليكم الشكر واصل للاخ ابو حنين حسب الطلب شاهد المرفق 2003 tarek.rar

السلام عليكم اخي الفاضل ناصر حفظه الله المعادلات المطلوبة مرتبطة بمعادلات اخرى والمعادلات الاخرى مرتبطة باخرى وهكذا يعني الواحد لازم يعرف آلية عمل كل معادلة والملف كبير !!! وهذا يفسر عدم وجود اي محاولات من الاعضاء تقبل تحياتي وشكري

السلام عليكم هذه الكود يستورد من ثلاثة اوراق ويمكنك التعديل في بداية الكود حسب ما هو موضح ' اسماء الاوراق التي تريد التعامل معهم ' يمكنك اضافة اسم اي ورقة على شرط ان تكون موجودة في الملفين ' هذا الكود يقوم بالاستيراد من ثلاث اوراق حسب الاسماء ادناه Const nSheet As String = "Statment,Stor,Buys" ' اسم الملف الذي تريد الاستيراد منه Const nBook As String = "ملف 1" & ".xls" Sub kh_DateImport1() Dim ib As Boolean Dim nSh Dim wo As Workbook Dim MyPath As String, rAd As String On Error GoTo 1 Set wo = ThisWorkbook For Each nSh In Split(nSheet, ",") wo.Worksheets(CStr(nSh)).UsedRange.ClearContents Next MyPath = ActiveWorkbook.Path & "\" & nBook '--------------------------------------- ' هل الملف مغلق ib = Not Workbook_Open(nBook) '--------------------------------------- Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' اذا الملف مغلق يقوم بفتحه If ib Then Workbooks.Open MyPath '--------------------------------------- For Each nSh In Split(nSheet, ",") Workbooks(nBook).Worksheets(CStr(nSh)).UsedRange.Copy wo.Worksheets(CStr(nSh)).Range("A1").PasteSpecial xlPasteValues Application.CutCopyMode = False Next '--------------------------------------- ' اذا كان الملف مغلق سابقا يقوم باغلاقه If ib Then Windows(nBook).Close '--------------------------------------- 1: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else: MsgBox "تم الاستيراد بنجاح" End If Set wo = Nothing End Sub يمكك الاستغناء عن الكود السابق الدالة ايضا تستخدم في هذا الكود لا تقوم بحذفها شاهد المرفق 2003 Data1-2.rar

السلام عليكم الف شكر اخي رجب -------حفظك ربي على سرعة التلبيه اكرمك الله في الدارين ورزقك من حيث لا تحتسب تقبل تحياتي وشكري

اكرمك الله اخي المجرب ما شاء الله عليك انت تفهمها وهي طائرة حفظك الله تقبل تحياتي وشكري

السلام عليكم الليبلات داخل الفرمة تحدد عدد الاعمدة المطلوبة الموجود داخل الفرمة 5 ليبلات يضيف 2 بجانب الموجود تقبل تحياتي وشكري

السلام عليكم اخي الحبيب رجب -حفظه الله تطبيق رائع للدروس بارك الله فيك وجزاك خيرا يمكنك وضع هذا الكود في موضوع المصفوفات كمثال تطبيقي تقبل تحياتي وشكري

السلام عليكم اخي الحبيب رجب جاويش ---------------حفظه الله احسنت بارك الله فيك تقبل تحياتي وشكري

السلام عليكم استبدل الكود المذكور سابقا بهذا ib = LCase(.Cells(R, MyColmnFind)) Like LCase(Me.TextFind.Text) واستخدم نجمة * بعد قيمة البحث سيعطيك تتطابق بداية السلسلة النصية اواستخدمها قبل وبعد قيمة البحث ستعطيك نتائج واسعة تعليمات عن أحرف البدل يمكن استخدام أحرف البدل التالية كمعايير مقارنة لعوامل التصفية وعند البحث عن محتوى واستبداله. استخدم للبحث عن ؟ (علامة استفهام) أي حرف مفرد على سبيل المثال، يتم العثور على "سمير" و"سفير" عند كتابة س؟ير. * (علامة نجمية) أي عدد من الأحرف على سبيل المثال، يتم العثور على "شمال شرق" و"جنوب شرق" عند كتابة *شرق ~ (تيلدا) متبوعة بـ ؟، أو *، أو ~ علامة استفهام، أو علامة نجمية، أو تيلدا على سبيل المثال، يتم العثور على "حر91؟" عند كتابة حر91~؟