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

السلام عليكم الاخ الفاضل / صفوت -------------حفظه الله وصلت رسالتك وشكرا جزيلا لمحتواها وبالنسبة لايميلي موجود في توقيعي نهاية كل مشاركة بامكانك مراسلتي في اي وقت تريد ولاي شي تريد تقبل تحياتي وشكري. ============ الاخ الاستاذ الفاضل/ amhateb-------------حفظه الله شكرا جزيلا لمحتوى مشاركتك من كلام طيب واسئلة في محلها بالنسبة للزر اولاً : بامكانك الاستغناء عنه وعن الكود المربوط به واضف زرين آخرين واربط واحد بكود الاضافة والآخر بكود الحذف ثانيا: Set XX = ورقة3.Shapes("الدائرة") اي ورقة في الاكسل يكون لها اسم خاص بالموديل خاصتها وهو المسمى (codename) وهو غير الاسم الذي امامنا في اسفل الورقة في النسخة العربية :ورقة1,ورقة2,ورقة3 في النسخة الانجليزية:Sheet1,Sheet2,Sheet3 هذه التسمية لا تتغير الا اذا قمت انت بتغييرها من كود الورقة نفسه انظر الى الصورة التالية: انا استخدم دائما في الاكواد codename حتى يعطينا حرية تغيير اسم الورقة الذي يظهر اسفل الاطار بدون ان غير اي شي في الكود . لما تنقل الكود لورقة معينة في ملف انظر الى كود النيم خاصتها واستبدله بدلا من ورقة3 ولنقل مثلا : ورقة26 Set XX = ورقة26.Shapes("الدائرة") وبامكانك ايضا استخدام التعبير التالي الذي يغنيك عن ما ذكر اعلاه Set XX = ActiveSheet.Shapes("الدائرة") ثالثا: اي زر موجود على الورقة له اسم معين يظهر لك في مربع الاسم عندما تاشر على هذا الزر انظر الى الصورة : و بامكانك تغيير هذا الاسم انا سميت هذا الزر (الدائرة) بامكانك اختيار الطريقة التي تريدها من الطرق ادناه: 1-لما تربط اي زر بكود الاضافة و الحذف سمي هذا الزر (الدائرة) 2-غير الاسم الموجود في الكود باسم الزر الجديد 3- نسخ الزر المسمى الدائرة الى الملف الجديد ارجوا ان اكون وفقت في توصيل هذه المعلومة ودمتم في حفظ الله ورعايته

السلام عليكم الاخ الفاضل / ياسر خليل---------------حفظه الله استخدم الكود التالي: Sub KH_START() Dim MyRange As Range Dim R As Integer, C As Integer, M As Integer, O As Integer Set MyRange = Range("School") M = 3 O = 3 KH_ClearContents Application.ScreenUpdating = False With MyRange For R = 1 To .Rows.Count If .Cells(R, 1) <> "" Then If Val(.Cells(R, 3)) = Val(Range("J3")) And Val(.Cells(R, 4)) = Val(Range("K3")) Then If .Cells(R, 5) = "ذكر" Then Cells(M, 1) = M - 2 Cells(M, 2) = .Cells(R, 2) Cells(M, 3) = .Cells(R, 6) Cells(M, 4) = .Cells(R, 7) M = M + 1 End If If .Cells(R, 5) = "أنثى" Then Cells(O, 5) = O - 2 Cells(O, 6) = .Cells(R, 2) Cells(O, 7) = .Cells(R, 6) Cells(O, 8) = .Cells(R, 7) O = O + 1 End If End If End If Next R End With Application.ScreenUpdating = True End Sub تفضل المرفق School_Record_2009.rar

السلام عليكم كود مشابه للكود للاخ الفاضل ابواسامة مع امكانية البحث عن الدولة دبل شيك على خلية الاسم KH_TEST.rar

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

السلام عليكم ردا لما قيل في احد المواضيع ان هذا الكود انا قمت به فهذا غير صحيح وانما قمت فقط بالتعديل عليه ليتناسب مع طلب معين في احد المواضيع واظن انه لاخي الفاضل / ابواسامة او لاخي الفاضل نزار (ابوخالد) او يمكن لاحدهم الله اعلم المهم جزاء الله من قام به خيرا وجعله في ميزان حسناته ============================= عموما لاهمية الموضوع وردا على اسئلة الاخوة (ناصر سعيد وكات وابن النيل ) فقد قمت باضافة بعض التعديلات الاخرى مع شرح مبسط في الكود وجعلت هذا المرفق كمثال ويمكن التطبيق عليه في ملف آخر مع بعض التعديلات البسيطة لموقع عمود رقم الجلوس ولموقع صف الدرجات ولنطاق الخلايا المراد وضع الدوائر فيها ============================= وايضا بامكانية استخدام الكود عند تكبير اوتصغير الورقة ActiveWindow.Zoom ____________________2.rar ============================= ارجوا الانتباه الى المشاركة رقم 30 يوجد فيها المرفق المعدل وكود ترحيل الناجحين ودور ثاني ============================= ============================= ارجوا الانتباه الى المشاركة رقم 42 يوجد فيها ملف لعمل الشهادات واضافة الدوائر فيها ============================= ============================= ارجوا الانتباه الى المشاركة رقم 58 الملف المعدل الشامل =============================

السلام عليكم الاخ الفاضل / عصام ---------------حفظه الله تفضل المرفق وفيه شرح مبسط في الكود : Option Explicit Dim Mybook As Workbook Dim path As String Dim MyRange As Range Dim MyCell As Range Dim Last_Count As Integer Dim LastRow As Integer Private Sub CommandButton2_Click() Mybook.Activate Unload Me End Sub Private Sub KHOpenFilename_Click() On Error GoTo 1 path = Application.GetOpenFilename(Title:="Select database location") KH_TEXT.Text = path Application.ScreenUpdating = False Application.DisplayAlerts = False Workbooks.Open path RefEdit1.SetFocus Application.ScreenUpdating = True Application.DisplayAlerts = True On Error GoTo 0 1 End Sub Private Sub KHCOPYMYRANGE_Click() On Error Resume Next Dim MySheet As Workbook Dim M As Integer, N As Integer, NN As Integer, C As Integer Dim lRows As Integer If RefEdit1.Text = "" Then GoTo 1 On Error GoTo 1 kh_focopy.Hide Application.ScreenUpdating = False With Range([RefEdit1]) M = .Rows.Count For lRows = 1 To M If .Cells(lRows, 1) <> "" Then '======================================================= ' كل صفين يتم اضافة البيانات N = N + 2 '======================================================= ' تسلسل البيانات المرحلة NN = N / 2 MyCell.Cells(N, 1) = NN + Last_Count '======================================================= ' سلسلة اعمدة البيانات تمتد من 1 الى 92 بداية من عمود الاسماء For C = 1 To 92 ' ترحيل البيانات MyCell.Cells(N, C + 1) = .Cells(lRows, C) Next C '======================================================= End If Next lRows End With '======================================================= MsgBox "تم استيراد عدد " & Chr(32) & NN & Chr(32) & " من السجلات بنجاح", 524288 + vbMsgBoxRtlReading, "الحمدلله" '======================================================= Application.ScreenUpdating = True Mybook.Activate End GoTo 2 1: MsgBox "استخدام خاطىء", 524288, "تنبيه" On Error GoTo 0 2 End Sub Private Sub UserForm_Initialize() Dim X As Integer Set Mybook = ActiveWorkbook With ActiveSheet '============================== ' اول صف في البيانات الاساسية هو 14 X = 14 ' آخر صف في البيانات الاساسية زايدا 1 LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1 '============================== If LastRow < X Then LastRow = X Set MyCell = .Range("A" & LastRow) '============================== ' عدد البيانات لاحتساب الرقم التسلسلي Last_Count Last_Count = Application.WorksheetFunction.CountA(.Range("A" & X & ":A" & LastRow)) End With End Sub =========================================================== الاخ الفاضل / IMAG---------------حفظه الله اجعل الطلب في موضوع آخر مع ارسال مرفقات كامثلة ودمتم في حفظ الله ________.rar

السلام عليكم Sub KH_ADD_ROW() On Error Resume Next Dim X As Integer, R As Integer, T As Integer X = Range("A" & Rows.Count).End(xlUp).Row - 7 R = 8 Application.ScreenUpdating = False For T = 1 To X Range("A" & R).EntireRow.Insert , CopyOrigin:=xlFormatFromRightOrBelow R = R + 2 Next Application.ScreenUpdating = True On Error GoTo 0 End Sub تفضل المرفق __________.rar

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

السلام عليكم Set MyRng = Range("K8:K1000,H8:H1000,E8:E1000") ودمتم في حفظ الله

السلام عليكم ورحمة الله وبركاته الحمد لله يمكن التعديل ولكن هذا طلب صاحب الموضوع هو عايزه بالشكل ده حسب فهمي للموضوع ================================= ولكن حسب ما طلبت سيكون كود سهل خاصة اذا الغينا دمج الخلايا في ورقة الطباعة ارسل مرفق ليتم التطبيق عليه

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

السلام عليكم عند الانتقال الى الورقة الخاصة بالطباعة تتعدل البيانات Private Sub Worksheet_Activate() KH_START End Sub الكود الخاص بالترحيل KH_START Sub KH_START() Dim MyCell As Range Set MyCell = Range("البيانات") Dim X As Integer, C As Integer, CC As Integer Dim R As Integer, RR As Integer Application.ScreenUpdating = False '========================== ' مسح البيانات المرحلة السابقةان وجدت With ورقة2 X = .UsedRange.Rows.Count + 6 .Range("B7:K" & X).ClearContents End With '============================ ' ترحيل البيانات الجديدة RR = 7 With MyCell For C = 1 To 3 CC = Choose(C, 3, 7, 11) For R = 1 To .Rows.Count If .Cells(R, CC) <> "" Then ورقة2.Cells(RR, 2) = .Cells(R, CC - 2) ورقة2.Cells(RR, 5) = .Cells(R, CC - 1) ورقة2.Cells(RR, 8) = .Cells(R, CC) RR = RR + 2 End If Next R Next C End With Application.ScreenUpdating = True End Sub تفضل المرفق ________________________.rar

السلام عليكم بعد اذن اخي الحبيب ابو اسامة يمكنك البحث من خلال الخلية A6 Private Sub Worksheet_Change(ByVal Target As Range) Dim X As Integer, Y As Integer KH_Range If Target.Address = MyCell.Address Then If MyCell <> "" And IsNumeric(MyCell) Then X = MyCell.Value + 3 For Y = 1 To 21 MyRange.Areas(Y) = ورقة2.Cells(X, Y + 2) Next Y Else MyRange.ClearContents End If End If End Sub وتعديل البيانات وترحيلها مرة اخرى Public MyRange As Range, MyCell As Range Sub KH_Range() Set MyRange = ورقة1.Range("B6,C6,A12,B12,C12,D12,E12,F12,G12,H12,A15,B15,C15,D15,E15,F15,G15,H15,E6,F6, G6") Set MyCell = ورقة1.Range("A6") End Sub Sub KH_START() Dim X As Integer, Y As Integer KH_Range If IsEmpty(MyCell) Or IsNumeric(MyCell) = False Then MsgBox "استخدام خاطىء": GoTo 1 X = MyCell.Value + 3 For Y = 1 To 21 ورقة2.Cells(X, Y + 2) = MyRange.Areas(Y) Next 1 MyCell.ClearContents End Sub تفضل المرفق ___________.rar

السلام عليكم عملت تطبيق مثل الصورة المرسلة لمادتين Range("J8:M1000") عمود رقم الجلوس هو العمود رقم 2 اما الصف حسب صف الخلية C Cells(C.Row, 2) تفضل المرفق ______3.rar

السلام عليكم استخدم المعادلة التالية: =IF(B3<>0;27.35;0)+IF(D3<>0;27.35;0)+IF(F3<>0;27.35;0)-(B3+D3+F3) تفضل المرفق DAYDAY.rar

السلام عليكم الاخ الفاضل / عصام -----------------حفظه الله الاخ الفاضل / خالد القدس-----------------حفظه الله الاخ الفاضل / تامر جمال-----------------حفظه الله الاخ الفاضل / أ مجدي-----------------حفظه الله الاخ الفاضل / احمد-----------------حفظه الله الاخ الفاضل / حبيبي دائما-----------------حفظه الله الاخ الفاضل / ياسر خليل-----------------حفظه الله ولك بمثل دعائكم اضعاف مضاعفة تقبلوا شكري وتقديري

السلام عليكم Sub Circles1() Dim c As Range Dim MyRng As Range Set MyRng = Range("e8:e1000") For Each c In MyRng If c(1, -2).Value = 0 Then GoTo 1 If c.Value < Cells(7, 5) Or c.Value = "غ" Or c.Value = "غـ" Then Set v = ActiveSheet.Shapes.AddShape(msoShapeOval, c.Left, c.Top, c.Width, c.Height) v.Fill.Visible = msoFalse v.Line.ForeColor.SchemeColor = 10 v.Line.Weight = 1.25 End If 1 Next End Sub

السلام عليكم الاخ / zine pef------حفظه الله اضافة مفيدة وعمل متعوب فيه اكرمك الله تقبل تحياتي وشكري

السلام عليكم الاخ الفاضل / الغريب 1 -----------------حفظه الله ولك بمثل دعائك اضعاف مضاعفة تقبل شكري وتقديري الاخ الحبيب / هادي سالم ------------حفظه ربي ادام الله قدرك واكرمك في الدنيا والاخرة تقبل شكري وتقديري

السلام عليكم الاخ الفاضل/ سالم شباني ------حفظه الله تفضل المرفق وتقبل مني شكري وتقديري ======================== الاخ الفاضل/ قصي------حفظه الله انت احلى عسل ممكن وقد عملتها في برنامج خبور الاصدار الثالث الذي ساضيفه قريبا الى المنتدى إن شاء ربي وتقبل مني شكري وتقديري ========================== الاخ الفاضل/ يحي------حفظه الله الله ينور عليك ويكرمك دنيا واخره وتقبل مني شكري وتقديري _____.rar

السلام عليكم الاخ الحبيب / نزار ( ابوخالد) ------------- حفظه الله هنا موضوع للسؤال عنك وانت ما يشغلك السؤال عن اخوانك الاخرين اي اخلاق عالية تتميز بها اخي الكريم حفظك ربي من كل شر وسهل لك كل معسر وادخلك الجنة من كل باب. اخوك خبور

السلام عليكم اريد توضيح ما فائدة دمج الخلايا ؟؟؟ يعني مئلا الاسم موضوع في عمودين b و c هل تريد نقل البيانات الى اوراق الاخرى حسب السنة بشكلها الحالي المدمج ؟؟؟

السلام عليكم اخي الفاضل اردت توجيه انتباهك للموضوع في الرابط ادناه http://www.officena.net/ib/index.php?showtopic=28127 وهو احد طلباتك في موضوع استيراد بيانات من ملف وقد لا تنتبه لذلك لانه في قسم غير الاكسل اخوك خبور خير