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

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

تحياتي وسلامي

اخوكم/ خبور
_________________1.rar

السلام عليكم

تم اضافة الشرط المطلوب في الكود


Sub Macro1() On Error Resume Next If Application.WorksheetFunction.CountA(Range("B6:E14")) = 0 Then MsgBox "خلايا فارغة": GoTo 1 ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True On Error GoTo 0 1 End Sub
test.rar

السلام عليكم


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

دبل شيك على خلية الاسم



KH_TEST.rar

السلام عليكم
الاخ الفاضل/ ابوخالد-------------------حفظه الله

تقبل تحياتي وشكري

السلام عليكم

تفضل المرفق
_________________.rar

السلام عليكم

شكرا اخي على هذا التنبيه

تم التعديل
_____________________________________.rar

السلام عليكم

ستجد المرفق في الموضوع

http://www.officena.net/ib/index.php?showtopic=26897

جعلناه لتعم الفائدةعلى الجميع

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

السلام عليكم

استخدم الكود التالي:


Private Sub CommandButton4_Click() Dim MyAr Dim MySh As Worksheet Dim C As Integer Set MySh = Sheets("farest") MyAr = Array("E:BH", "AH:BB", "BJ:CD", "CK:FP", "FW:IV") With MySh .Cells.EntireColumn.Hidden = False .Rows("1:15").EntireRow.Hidden = True For C = 0 To 4 .Columns(MyAr(C)).EntireColumn.Hidden = True Next .PrintPreview End With End Sub

السلام عليكم
 
جزاكم الله خيرا  اخي الكريم ياسر
 
ائراءا للموضوع
بدون استخدام معادلات على الخلايا
Sub kh_Start() Dim obj Dim Lr As Integer, iRnd As Integer, i As Integer Lr = Cells(Rows.Count, "A").End(xlUp).Row - 1 '======================================== Set obj = CreateObject("Scripting.Dictionary") '======================================== Do     iRnd = Int((Rnd * Lr) + 1)     If Not obj.Exists(iRnd) Then         i = i + 1         obj.Add iRnd, i         Range("F2").Cells(i, 1).Resize(1, 2).Value = Range("A2").Cells(iRnd, 1).Resize(1, 2).Value     End If     If i = 10 Then Exit Do Loop Set obj = Nothing End Sub المرفق 2003
Random word Generator2.rar

السلام عليكم
 
الشكر واصل للاخ ابو تراب............ حفظه الله
 
وائراءا للموضوع
 
ممكن استخدام هذا الكود التالي  بدون تحديد اسماء للبوكس شيك ولا للخلايا
تستدل بالخلايا بموضع الشيك بوكس

Sub kh_UpdateBoxes() Dim tx As String On Error Resume Next With Sheet1.Shapes(Application.Caller)     If .ControlFormat.Value = 1 Then tx = "*" Else tx = ""     .TopLeftCell.Offset(1, 0).Value = tx End With On Error GoTo 0 End Sub المرفق 2010
تشيك بوكس.rar

السلام عليكم
 
يكفي ان تضع  هذا الكود في الفورم

Private Sub UserForm_Activate() Dim i As Integer, j As Integer For i = 1 To 100     For j = 1 To 1000         DoEvents     Next j     Me.Text.Caption = i & "% Completed"     Me.Bar.Width = i * 2 Next i End Sub تحياتي

السلام عليكم
 
جرب هذه المعادلة لحساب اليوم
=MOD(DAYS360(E8+IF(DAY(E8)=31;1;0);D8);30) اما الشهر والسنة تبقى المعادلات مثل المرفق في المشاركة الاولى
 
تحياتي

السلام عليكم
 
الكود خطأ
 
استبدل بهذا

Private Sub UserForm_Initialize() Dim i As Integer For i = 6 To Cells(Rows.Count, "A").End(xlUp).Row     If CStr(Cells(i, "B")) = "نعم" Then Me.ComboBox1.AddItem Cells(i, "A").Value Next End Sub تحياتي

السلام عليكم

جرب هذا
Private Sub CommandButton1_Click() VBA.Calendar = vbCalHijri Application.ScreenUpdating = False q = [b2000].End(xlUp).Row + 1 Range("b" & q) = TextBox1.Value Range("c" & q) = TextBox2.Value Range("d" & q) = TextBox3.Value Range("e" & q) = ComboBox1.Value Range("f" & q) = CDate(TextBox4) Range("g" & q) = TextBox5.Value Application.ScreenUpdating = True MsgBox "data has been succesfully recorded", okonly, "attention" VBA.Calendar = vbCalGreg Unload Me End Sub
تحياتي

السلام عليكم
 
تم بالمعادلات
شاهد المرفق 2010
 
استخراج بيانات فاتورة بحسب رقمها.rar

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

Sub kh_Start() Dim v, vv Dim Sh1 As Worksheet, Sh2 As Worksheet Dim Lr As Integer, i As Integer Set Sh1 = Sheets("عرض مبدئي") Set Sh2 = Sheets("العملاء") vv = Array("c11", "H12", "", "J14", "J16", "c12", "j18", "j20", "j22", "j44", "j48", "j32", "j38", "j36", "j34", "j40", "j522", "j50", "j54", "j56") Lr = Sh2.Cells(Rows.Count, "A").End(xlUp).Row + 1 For Each v In vv     i = i + 1     If Not IsError(Sh1.Evaluate(v)) Then         Sh2.Cells(Lr, i).Value = Sh1.Range(v).Value     End If Next Set Sh1 = Nothing: Set Sh2 = Nothing End Sub المرفق 2003
aaaaaaaaaaaaa.rar
 
تحياتي

السلام عليكم
 
حسب ما فهمت
المرفق 2003
3 times.rar

السلام عليكم
 
هذا سبب الخطأ في ملفك
قم باضافتهما  الى ملفك

السلام عليكم
 
 
استبدل السطر
With Range(Range("A5"), Range("A5").End(xlDown)).Resize(, 9).Borders(xlEdgeBottom) بهذا السطر
With Cells(Cells(Rows.Count, "i").End(xlUp).Row, "a").Resize(1, 9).Borders(xlEdgeBottom) تحياتي

السلام عليكم
 
لإضافة ورقة جديدة
إضغط الزر في شريط تبويب الاوراق (غير مستخدمي 2003)
أو
SHIFT+F11
او باستخدام كود لاضافة ورقة وتربطه بزر
مثلا:
Sub xxxx() Sheets.Add End Sub المهم انه في كل الحالات سيتم اضافة الورقة الجديدة حسب طلبك
الكود موجود في ThisWorkbook
ويمكنك تغيير تسمية الاشهر في الكود

Private Sub Workbook_NewSheet(ByVal Sh As Object)     Dim m, d, y, mAry     Dim i As Long     On Error GoTo 1     '  قم بتسمية الاشهر هنا حسب ما تناسبك     mAry = Array("Jan", "Fév", "Mars", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")     i = Sheets.Count     If Sh.Index <> i Then Sh.Move , Sheets(i)          d = Sheets(i - 1).Name     m = Split(d, "-")(0): y = Split(d, "-")(1)     m = WorksheetFunction.Match(CStr(m), mAry, 0)     d = DateValue("13/" & m & "/" & y)     d = DateSerial(Year(d), m + 1, 1)     Sh.Name = mAry(Month(d) - 1) & "-" & Format(d, "yy") 1 End Sub المرفق 2003-2010
اضافة ورقة جديدة بتسمية معينة.rar
 
تحياتي

السلام عليكم
 
تم استخدام دالة معمولة بالكود kh_Names
تجد موضوعها على الرابط
 
http://www.officena.net/ib/index.php?showtopic=49057
 
المرفق 2010
ملف عينة.rar

السلام عليكم
بعد اذن المشاركين حفظهم الله
 
كنت قد جهزت هذا الملف بهذه المعادلة في قاعدة التحقق من الصحة
=OFFSET(MyNames;MATCH(CELL("contents")&"*";MyNames;0)-1;;COUNTIF(MyNames;CELL("contents")&"*")) المرفق 2003
تصفية القائمة.rar

السلام عليكم
 
شاهد المرفق 2010
فرق الايام.rar

السلام عليكم
ممكن هذه المعادلة مع وجود الدمج في العمود M
وتغيير الكلمات في العمود N من اناث الى انثى ومن ذكور الى ذكر
=SUMPRODUCT(N($J$4:$J$400=O$3);N($F$4:$F$400=IF(LEN($M4);$M4;$M3));N($G$4:$G$400=$N4)) المرفق 2003
حساب اعمار طلبة.rar