سليم حاصبيا

ربما كان المطلوب aamir_cod_form.xlsm

تم التعديل على الملف لاظهار قائمة منسدلة مطاطة (تستجيب لاي تغيير / اضافة/ مسح / تعديل ) في البيانات tp_salim1.xlsx

شاهد هذا النموذج calculate_between.xlsx

جرب هذا الملف tp_salim.xlsx

لاحظ المعادلة التي ادرجتها لك في الصفحة "بيانات أساسية" العامود G لا لزوم للمعادلة التي كانت (طويلة و مرهقة للاكسل و تتطلب عامود اضافي) =MID($D5,1,SEARCH("-",$D5)-1) بالنسية للموضوع ستدعاء بيانات من شيتين ومن اعمده بعيده ووضعها في شيت الترحيل سافكر بالامر لاحقاً (حسب الوقت)

بعد اذن اخي علي هذا الملف (تم تفيير بعض الاشياء في الملف لحسن عمل الكود) الكود Option Explicit Sub filter_me() If ActiveSheet.Name <> "احصاء العمر" Then GoTo Leave_Me_Alone Application.ScreenUpdating = False ActiveSheet.Range("b5:I20").ClearContents Dim clas_arr() Dim s%, k%, m%, n% m = 2: n = 3 ReDim clas_arr(1 To 4) clas_arr(1) = "الاول": clas_arr(2) = "الثاني" clas_arr(3) = "الثالث": clas_arr(4) = "الرابع" For s = 1 To 4 For k = 5 To 20 Range("filter_range").AutoFilter Field:=10, Criteria1:=k Range("filter_range").AutoFilter Field:=7, Criteria1:="=" & clas_arr(s) Range("filter_range").AutoFilter Field:=5, Criteria1:="ذكر" Cells(k, m) = Sheets("بيانات أساسية").Cells(1, "M").Value Range("filter_range").AutoFilter Field:=10, Criteria1:=k Range("filter_range").AutoFilter Field:=7, Criteria1:="=" & clas_arr(s) Range("filter_range").AutoFilter Field:=5, Criteria1:="انثى" Cells(k, n) = Sheets("بيانات أساسية").Cells(1, "M").Value Next m = m + 2: n = n + 2 Next Leave_Me_Alone: Erase clas_arr Range("filter_range").AutoFilter Application.ScreenUpdating = True End Sub الملف مرفق salim_filter.xlsm

هذه المعادلة =DATE(YEAR(L13)+L14,MONTH(L13)-1,DAY(L13))

حرب هذا الملف مطابقةsalim.xlsx

انظر الى الصفحة Salim من هذا الملف New_Ages.xlsx

حرب هذا الملف تلوين الأرقامsalim.xls

جرب هذا الملف Only_One_letter.xlsm

هناك موضوع مشابه على هذا العتوان https://www.officena.net/ib/topic/84505-حذف-مشاركة/

لا أعلم بالضبط اذا كان هذا المطلوب Salim.xlsx

الاخ Alawani بعد السلام ..... يرجى اعادة المشاركة (مع عدم تكرارها) و ذلك كي يستفيد منها اكبر عدد من المشاركين مع ذكر الحل وعنوانه

نسخة من الملف بتنسبق 2003 protect non empty data with Pass word.xls

هذه المعادلة =IF(OR(C3<1,C3>12,ISTEXT(C3)),"",13-C3)

بسبب بطء النت لم اسنطع تحميله والان ارفع الملف من جديد في نفس المشاركة الاولى

من الملفات القديمة التي تمت مشاركتي لها والتي تطلب غالباً كيف نحمي الخلايا غير الفارغة بواسطة باسوورد (الباسورد في الملف / الخلية H3/ يمكن حفظة و مسحه عن عيون الفضوليين) مع حرية الغاء الجماية كما تشاء protect non empty data with Pass word.xlsm

تم تكرار مشاركة من قبل احد الاعضاء(Alawani) ولما قمت بحذف الثانية المكررة تفاجأت بأنه تم حذف الاثنتين معاً ما السبب يا ترى؟ (سؤال الى الادارين) سؤال اخر :لماذا ممنوع علينا نحن فريق الموقع التواصل مع (الاعضاء الجدد) عبر الرسائل الخاصة بينما هم يستطيعون مع العلم اني قد قمت بالرد على المشاركة ووضع الكود اللازم لها لكن للاسف لا استطبع رفع الرد لهذا سادرج الكود هنا مع الملف (مضافاً اليه الكود) مع الاعتذار لصاحب المشاركة الاخ (Alawani) Option Explicit Sub give_certificates() With Application .EnableEvents = False .ScreenUpdating = False End With Dim Target1 As Worksheet, Target2 As Worksheet Dim sh_1 As Worksheet, sh_2 As Worksheet Dim lr1%, lr2% Dim i% Set Target1 = Sheets("Prim_cert"): Set Target2 = Sheets("Sec_cert") Set sh_1 = Sheets("Primery"): Set sh_2 = Sheets("second") lr1 = sh_1.Cells(Rows.Count, 1).End(3).Row lr2 = sh_2.Cells(Rows.Count, 1).End(3).Row Select Case ActiveSheet.Name Case "Prim_cert" For i = 13 To lr1 Step 2 ActiveSheet.Range("h2") = i - 12 ActiveSheet.Range("h23") = i - 11 '--------------------------------- ' ActiveSheet.PrintOut 'للطباعة احذف الفاصلة العليا من هذا السطر '--------------------------------- Next Case "Sec_cert" For i = 13 To lr2 Step 2 ActiveSheet.Range("h2") = i - 12 ActiveSheet.Range("h20") = i - 11 '--------------------------------- ' ActiveSheet.PrintOut 'للطباعة احذف الفاصلة العليا من هذا السطر '--------------------------------- Next Case Else GoTo Exit_me End Select Exit_me: With Application .EnableEvents = True .ScreenUpdating = True End With End Sub الملف مرفق كي يقوم الكود بالطباعة يجب حذف الفاصلة العليا من السطرين 21 و 29 من هذا الكود yahoo_salim.xlsm

هذا الكود Option Explicit Sub give_integer() Range("XFD3").Resize(Application.CountA(Range("D:D")), 1).Formula = _ "=ROUND(d3,0)" Range("d3").Resize(Application.CountA(Range("D:D")), 1).Value = _ Range("XFD3").Resize(Application.CountA(Range("D:D")), 1).Value Range("XFD3").Resize(Application.CountA(Range("D:D")), 1).Clear End Sub

الملف مع الكود Posting_with msg_salim.xlsm

الكود الجديد مع رسالة التحذير Option Explicit Sub Copy_non_contiguous_ranges() Dim LR As Long, ws As Worksheet, ws2 As Worksheet Dim Num, s% Dim answer As Byte Set ws = Sheets("Sheet1") Set ws2 = Sheets("Sheet2") If Not IsNumeric(ws.Range("c1")) _ Or ws.Range("c1") = vbNullString Then Num = 1 Else Num = Int(Abs(ws.Range("c1"))) End If Select Case Num Case 1 s = 0 Case Else s = 2 * Num - 1 End Select s = IIf(s > 1, s - 1, s) LR = ws.Range("a" & Rows.Count).End(xlUp).Row If ws.Range("a2").Value = "" Then MsgBox ("No Data to transfere ") Exit Sub Else If ws2.Range("a2").Offset(, s) = "" _ Or ws2.Range("a2").Offset(, s + 1) = "" Then '======================== ws.Range("a2").Resize(LR - 1, 1).Copy ws2.Range("a2").Offset(, s).PasteSpecial Paste:=xlPasteValues ws.Range("e2").Resize(LR - 1, 1).Copy ws2.Range("a2").Offset(, s + 1).PasteSpecial Paste:=xlPasteValues Else '============================ answer = MsgBox("The Distinatoion Ranges are Not Empty" & Chr(10) _ & "Do yo want to replace the data", vbYesNo, "salim tell you") If answer = 6 Then With ws2 .Range("a2").Offset(, s).Resize(100, 1).ClearContents .Range("a2").Offset(, s + 1).Resize(100, 1).ClearContents ws.Range("a2").Resize(LR - 1, 1).Copy .Range("a2").Offset(, s).PasteSpecial Paste:=xlPasteValues ws.Range("e2").Resize(LR - 1, 1).Copy .Range("a2").Offset(, s + 1).PasteSpecial Paste:=xlPasteValues End With Else GoTo Exit_Please End If End If End If Exit_Please: Application.CutCopyMode = False End Sub

ارفع ملف كنموذج للمعاينة

الماكرو المطلوب Option Explicit Sub calculate_by_VBA() Dim My_rg As Range Dim lr% lr = Sheets("رصد الدرجات").Cells(Rows.Count, 1).End(3).Row Set My_rg = Sheets("رصد الدرجات").Range("DC24").Resize(lr - 23, 8) My_rg.Formula = "=IFERROR(INDEX($A$24:$CX$500,ROWS($A$1:A1),MATCH(DC$21,$A$23:$CX$23,0)),"""")" My_rg.Value = My_rg.Value End Sub