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

السلام عليكم تفضل المرفق خبور خير Post Via Column & Row.rar

السلام عليكم بارك الله فيك اخي هشام مرسي عمل رائع تشكر عليه تقبل تحياتي وشكري

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

السلام عليكم تفضل المرفق معمول بالمعادلات خبور خير Copy Try.rar

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

السلام عليكم ورحمة الله وبركاته اوداود الاعتذار عن طولة غيابي لاسباب خارجة عن ارادتي اقدم اليكم هذا العمل كهدية بسيطة للخروج من الغياب الذي اصابني بالملل وحرمني من الاجر الملف معمول بالمعادلات . وقد شملت على عدة استخدامات للمعادلة SUMPRODUCT وبعدة طرق وكيفية اختصار الشروط المكررة . لن اطيل عليكم واشكر جميع من سال عني او خطرت على باله فلكم مني الشكر الجزيل يا عز عائلة اخوكم خبور خير برنامج كاس العالم 2010.rar

السلام عليكم الاخ الفاضل emadoo -------حفظه الله عمل رائع جدا ========================== مرفق ملف معمول بالمعادلات =SUMPRODUCT(--(INDEX(MyRng;0;1)=B3);--(INDEX(MyRng;0;2)=C3);--(INDEX(MyRng;0;3)=D3);INDEX(MyRng;0;4)) رواتب.rar

السلام عليكم الاخ الحبيب / ابو عبدالله -------------- حفظه الله انت يا اخي من المعدن النفيس واشكرك من كل قلبي على اتصالك و وسؤالك عني اكرمك الله في الدارين واسكنك الجنة والشكر واصل لجميع من سال عني وخطرت على باله. تقبل تحياتي وشكري ================================================== الاخ الفاضل/ الجزيرة -------------- حفظه الله جزاك الله خيرا وحفظك من كل مكروه تقبل تحياتي وشكري ================================================== الاخ الحبيب / هشام شلبي -------------- حفظه الله جزاك الله خيرا وحفظك من كل مكروه تقبل تحياتي وشكري ================================================== بالرغم من ان الموضوع " تضامناً مع أخينا خبور خير " هو موضوع قديم جدا وانا موجود معكم ولكن تواجدي قليلا بسبب انشغالي وقد شاركت قريبا في الموضوع http://www.officena.net/ib/index.php?showtopic=31957 ودمتم في حفظ الله

السلام عليكم غير الكود بالتالي: Private Sub CommandButton1_Click() Dim NUEVO As Workbook Dim MyName_Book, FileSaveName Dim MyName_Sheet As String Dim i As Integer, X As Integer, j As Integer, final As Integer '=============================== MyName_Sheet = jaboor.Cells(9, "F") MyName_Book = ActiveWorkbook.Path & "\" & MyName_Sheet & ".xls" Set NUEVO = Workbooks.Add(-4167) '=============================== For i = 38 To 1000 If jaboor.Cells(i, 1) = "" Then final = i - 1 Exit For End If Next '=============================== With NUEVO.Worksheets(1) .Name = MyName_Sheet For j = 13 To final For X = 1 To 12 .Cells(j - 12, X) = jaboor.Cells(j, X) Next X Next j End With '=============================== UserForm1.Hide '=============================== FileSaveName = Application.GetSaveAsFilename(MyName_Book, "xls Files (*.xls), *.xls") 1: If FileSaveName = False Then Exit Sub If Not Dir(FileSaveName, vbDirectory) = vbNullString Then MsgBox "اسم الملف مكرر " & Chr(10) & "قم بحفظه باسم آخر", vbCritical + vbMsgBoxRight, "تنبيه" FileSaveName = Application.GetSaveAsFilename(, "xls Files (*.xls), *.xls") GoTo 1 Else NUEVO.SaveAs FileSaveName MsgBox "Save as " & FileSaveName End If End Sub

السلام عليكم غير الكود بتاع الفورم الى التالي: Private Sub CommandButton1_Click() Dim NUEVO As Workbook Dim MyPath As String, MyName As String Dim i As Integer, X As Integer, j As Integer, final As Integer '=============================== MyName = jaboor.Cells(9, "F") MyPath = ActiveWorkbook.Path & "\" & MyName & ".xls" Set NUEVO = Workbooks.Add(-4167) '=============================== For i = 38 To 1000 If jaboor.Cells(i, 1) = "" Then final = i - 1 Exit For End If Next '=============================== With NUEVO.Worksheets(1) .Name = MyName For j = 13 To final For X = 1 To 12 .Cells(j - 12, X) = jaboor.Cells(j, X) Next X Next j End With '=============================== UserForm1.Hide '=============================== If Not Dir(MyPath, vbDirectory) = vbNullString Then MsgBox "اسم الملف مكرر لن يتم حفظه " & Chr(10) & "قم بحفظه بنفسك", vbCritical + vbMsgBoxRight, "تنبيه" Else NUEVO.SaveAs MyPath End If End Sub

السلام عليكم Private Sub CommandButton1_Click() Dim NUEVO As Workbook Dim MyPath As String, MyName As String Dim i As Integer, X As Integer, j As Integer, final As Integer '=============================== MyName = jaboor.Cells(9, "F") & ".xls" MyPath = ActiveWorkbook.Path & "\" & MyName Set NUEVO = Workbooks.Add(-4167) '=============================== For i = 38 To 1000 If jaboor.Cells(i, 1) = "" Then final = i - 1 Exit For End If Next '=============================== For j = 13 To final For X = 1 To 12 With NUEVO.Worksheets(1) .Cells(j - 12, X) = jaboor.Cells(j, X) End With Next X Next j '=============================== UserForm1.Hide '=============================== If Not Dir(MyPath, vbDirectory) = vbNullString Then MsgBox "اسم الملف مكرر لن يتم حفظه " & Chr(10) & "قم بحفظه بنفسك", vbCritical + vbMsgBoxRight, "تنبيه" Else NUEVO.SaveAs MyPath End If End Sub تفضل المرفق حوالات_اصدار جديد.rar

======================== الاخ الحبيب/ ابو عبدالله ======================== عمل رائع جداً جداً سلمت يداك و

السلام عليكم Private Sub CommandButton1_Click() Dim M Dim Last As Long Dim C As Integer, CC As Integer Last = Range("B65536").End(xlUp).Row + 1 M = Array(TextBox1.Value, ComboBox1.Value, ComboBox2.Value, ComboBox3.Value) For C = 1 To 4 '================== 'هنا يتم تحديدالاعمدة CC = Choose(C, 2, 5, 8, 10) '================== Cells(Last, CC) = M(C - 1) Next C End Sub

السلام عليكم مثلا: ActiveCell.Resize(1, 2).Value = Array("خالد", "خبور")

السلام عليكم الكود يعين المتغير Last آخر صف في العمود B زايداً واحد في الكود الاول يكتب مباشرة في النطاق المكون من اربعة اعمدة بداية من العمود B في الصف المحدد في المتغير Last في الكود الثاني يكتب مباشرة في النطاق المكون من خمسة اعمدة بداية من العمود A في الصف المحدد في المتغير Last

======================== الاخ الفاضل / HaNcOck ========================

السلام عليكم اذا اردت اضافة الترقيم في العمود الاول Private Sub CommandButton1_Click() Last = Range("B65536").End(xlUp).Row + 1 Range("A" & Last).Resize(1, 5).Value = Array(Last - 18, TextBox1.Value, ComboBox1.Value, ComboBox2.Value, ComboBox3.Value) End Sub

السلام عليكم ينفع الكود التالي لطلبك: Private Sub CommandButton1_Click() Last = Range("B65536").End(xlUp).Row + 1 Range("B" & Last).Resize(1, 4).Value = Array(TextBox1.Value, ComboBox1.Value, ComboBox2.Value, ComboBox3.Value) End Sub

السلام عليكم استخدم مثلا الكود التالي: Sub KH_Copy() On Error Resume Next Dim Last As Long Dim Count As Integer Count = 1 Count = Sheets("KHBOOR").Range("F9").Value With ActiveSheet Last = .Range("A" & .Rows.Count).End(xlUp).Row .Rows(Last).Copy .Rows(Last + 1).Resize(Count) .Rows(Last + 1).Resize(Count).SpecialCells(xlConstants).ClearContents End With On Error GoTo 0 End Sub شاهد المرفق KH_COPY.rar بطريقتين: 1- يدويا حدد اول صف فاضي آخر البيانات واضغط CTRL+D كذا حتضيف صف مثل الصف اللي فوقه مباشرة بالقيم والمعادلات وعليك تغيير القيم الجديدة 2- بالكود عن طريق زر او بحدث معين من احداث الورقة ممكن بقاعدة التحقق من الصحة او بالكود.

السلام عليكم استخدم الكود التالي: Sub KH_FillDown() Dim Last As Long Last = Range("A" & Rows.Count).End(xlUp).Row + 1 On Error Resume Next With Rows(Last) .FillDown .SpecialCells(xlConstants).ClearContents End With On Error GoTo 0 End Sub وهو يعتمد على اخر خلية في العمود A يضيف صف مع المعادلات فقط ويمسح القيم INVOICE.xls

======================== الاخ الفاضل / الخطة البديلة ========================

السلام عليكم ===== هنا سيتم شرح مواضيع الدوال

الشكر واصل لجميع المشاركين حفظكم الله ورعاكم خبور خير

السلام عليكم اخي الحبيب / ابو عبدالله ----------حفظه الله ما هو الصفر او false هي نفسها vbModeless Enum FormShowConstants Const vbModal = 1 Const vbModeless = 0 تقبل تحياتي وشكري

برنامج الجداول المدرسية المعدل بعد المناقشات التي تمت في موضوع البرنامج الاصدار الاول في الرابط ادناه برنامج الجداول المدرسية الاصدار الاول عبدالله باقشير برنامج الجدول المدرسي المعدل.rar