الـعيدروس

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

السلام عليكم الاخ الفاضل Creation World حمل مرفق المشاركة السابقة تم التعديل ان شاء الله يزبط معك

السلام عليكم بعد اذن الاساتذه الافاضل تعدد الحلول تفضل إظهار تكست_Ali_1.rar

السلام عليكم الاخ halimnacer ارفق مثال لو تكرمت

جرب هكذا فصلنا الحلقات Sub جمع_الكل() On Error Resume Next Dim RR&, R& With Application .ScreenUpdating = False .EnableEvents = False RR = Cells(Rows.Count, 1).End(xlUp).Row For R = 11 To RR For TT = 1 To 2 D1 = Choose(TT, 12, 18) D2 = Choose(TT, 23, 29) D3 = Choose(TT, 34, 40) D4 = Choose(TT, 46, 54) D5 = Choose(TT, 60, 68) D6 = Choose(TT, 73, 79) D7 = Choose(TT, 85, 93) D8 = Choose(TT, 96, 99) D9 = Choose(TT, 101, 104) DA = Choose(TT, 105, 107) If Cells(R, D1) = "غ" And Cells(R, D2) = "غ" And Cells(R, D3) = "غ" _ And Cells(R, D4) = "غ" And Cells(R, D5) = "غ" And Cells(R, D6) = "غ" _ And Cells(R, D7) = "غ" And Cells(R, D8) = "غ" And Cells(R, D9) = "غ" Then Cells(R, DA) = 0 Else Cells(R, DA) = Val(Cells(R, D1)) + Val(Cells(R, D2)) + Val(Cells(R, D3)) + _ Val(Cells(R, D4)) + Val(Cells(R, D5)) + Val(Cells(R, D6)) + _ Val(Cells(R, D7)) + Val(Cells(R, D8)) + Val(Cells(R, D9)) If Cells(R, D1) = "" And Cells(R, D2) = "" And Cells(R, D3) = "" _ And Cells(R, D4) = "" And Cells(R, D5) = "" And Cells(R, D6) = "" _ And Cells(R, D7) = "" And Cells(R, D8) = "" And Cells(R, D9) = "" _ Then Cells(R, DA) = "" End If Next Next For Rt = 11 To RR For T1 = 1 To 3 E1 = Choose(T1, 42, 56, 81) E2 = Choose(T1, 43, 57, 82) E3 = Choose(T1, 44, 58, 83) E4 = Choose(T1, 45, 59, 84) If Cells(Rt, E1) = "غ" And Cells(Rt, E2) = "غ" And Cells(Rt, E3) = "غ" Then Cells(Rt, E4) = "غ" Else Cells(Rt, E4) = Val(Cells(Rt, E1)) + Val(Cells(Rt, E2)) + Val(Cells(Rt, E3)) If Cells(Rt, E1) = "" And Cells(Rt, E2) = "" And Cells(Rt, E3) = "" Then Cells(Rt, E4) = "" End If Next Next For Rt1 = 11 To RR For T2 = 1 To 29 A1 = Choose(T2, 9, 14, 11, 20, 25, 22, 31, 36, 33, 49, 48, 45, 63, 62, 59, 70, 75, 72, 88, 87, 84, 95, 100, 109, 114, 111, 120, 125, 122) A2 = Choose(T2, 10, 15, 16, 21, 26, 27, 32, 37, 38, 50, 51, 52, 64, 65, 66, 71, 76, 77, 89, 90, 91, 97, 102, 110, 115, 116, 121, 126, 127) A3 = Choose(T2, 11, 16, 17, 22, 27, 28, 33, 38, 39, 51, 52, 53, 65, 66, 67, 72, 77, 78, 90, 91, 92, 98, 103, 111, 116, 117, 122, 127, 128) If Cells(Rt1, A1) = "غ" And Cells(Rt1, A2) = "غ" Then Cells(Rt1, A3) = "غ" Else Cells(Rt1, A3) = Val(Cells(Rt1, A2)) + Val(Cells(Rt1, A1)) If Cells(Rt1, A1) = "" And Cells(Rt1, A2) = "" Then Cells(Rt1, A3) = "" End If Next Next .ScreenUpdating = True .EnableEvents = True End With End Sub

الاخ يوسف باامكانك تغير النطاق من جزئية الكود التاليه مثلا انا جربت مع توسعه النطاق يبطي نوع ما Private Sub kh_MyRngSet() Dim Last As Long '======================== ' تعيين النطاق ويشمل رؤوس الاعمدة With Sheets("قاعدة البيانات") Last = .Range("C" & .Rows.Count).End(xlUp).Row Set Rng1 = .Range("A2:SP" & Last) End With '======================== With Sheets("قاعدة البيانات2") Last = .Range("C" & .Rows.Count).End(xlUp).Row Set Rng2 = .Range("A2:SP" & Last) End With End Sub

السلام عليكم الاخ الفاضل يوسف افضل ان يتم استدعاء الكود عند دخول المصنف وعند الاغلاق هكذا '********************** ' حدث ThisWorkbook Private Sub Workbook_BeforeClose(Cancel As Boolean) Call D_AlS End Sub Private Sub Workbook_Open() Call D_AlS End Sub ' '********************** '========================== ' مودويل Public Sub D_AlS() On Error Resume Next Dim RR&, R& Dim RT&, RI&, A%, B% Dim V_Ali As Variant With Application .ScreenUpdating = False .EnableEvents = False RR = Cells(Rows.Count, 1).End(xlUp).Row For R = 11 To RR For TT = 1 To 32 AC = Choose(TT, 9, 14, 11, 20, 25, 22, 31, 36, 33, 49, 48, 45, 63, 62, 59, 70, 75, 72, 88, 87, 84, 95, 100, 109, 114, 111, 120, 125, 122) AT = Choose(TT, 10, 15, 16, 21, 26, 27, 32, 37, 38, 50, 51, 52, 64, 65, 66, 71, 76, 77, 89, 90, 91, 97, 102, 110, 115, 116, 121, 126, 127) AD = Choose(TT, 11, 16, 17, 22, 27, 28, 33, 38, 39, 51, 52, 53, 65, 66, 67, 72, 77, 78, 90, 91, 92, 98, 103, 111, 116, 117, 122, 127, 128) If Cells(R, AC) = "غ" And Cells(R, AT) = "غ" Then Cells(R, AD) = "غ" Else Cells(R, AD) = Val(Cells(R, AC)) + Val(Cells(R, AT)) If Cells(R, AC) = "" And Cells(R, AT) = "" Then Cells(R, AD) = "" End If Next Next RT = Cells(Rows.Count, 1).End(xlUp).Row V_Ali = Array(12, 18, 23, 29, 34, 40, 46, 54, 60, 68, 73, 79, 85, 93, 96, 99, 101, 104) For RI = 11 To RT For TT = 1 To 18 D1 = Choose(TT, 12, 18, 23, 29, 34, 40, 46, 54, 60, 68, 73, 79, 85, 93, 96, 99, 101, 104) A = V_Ali(0) B = V_Ali(UBound(V_Ali)) DA = Choose(TT, 105, 107) If Cells(RI, D1) = "غ" Then Cells(RI, DA) = 0 Else Cells(RI, DA) = WorksheetFunction.Sum(Range(Cells(RI, Val(A)), Cells(RI, Val(B)))) If Cells(RI, D1) = "" Then Cells(RI, DA) = "" End If Next Next .ScreenUpdating = True .EnableEvents = True End With End Sub

غيرت العمود المراد اخذ اخر خليه بها بيانات منه للدلاله على تنفيذ الكود حتى اخر خليه بها بيانات فقط دون المرور على كافة الخلايا طلبك الاخير بدء من عمود "BD" والطلب السابق بدء من عمود 9 اللي هو "i" ارجو ان تكون وصلت المعلومه

العفو اخي يوسف جرب هكذا Private Sub Worksheet_Selectionchange(ByVal Target As Range) On Error Resume Next Dim RR&, R& With Application .ScreenUpdating = False .EnableEvents = False RR = Cells(Rows.Count, "BD").End(xlUp).Row For R = 11 To RR For TT = 1 To 12 AC = Choose(TT, 56, 81) AT = Choose(TT, 57, 82) AO = Choose(TT, 58, 83) AD = Choose(TT, 59, 84) If Cells(R, AC) = "غ" And Cells(R, AT) = "غ" And Cells(R, AO) = "غ" Then Cells(R, AD) = "غ" Else Cells(R, AD) = Val(Cells(R, AC)) + Val(Cells(R, AT)) + Val(Cells(R, AO)) If Cells(R, AC) = "" And Cells(R, AT) = "" And Cells(R, AO) = "" _ Then Cells(R, AD) = "" End If Next Next .ScreenUpdating = True .EnableEvents = True End With End Sub

السلام عليكم تفضل مجرد تعدد للحلول 55_Ali.rar

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

السلام عليكم تفضل الكود في حدث الصفحه Private Sub Worksheet_Selectionchange(ByVal Target As Range) On Error Resume Next Dim RR&, R& With Application .ScreenUpdating = False .EnableEvents = False RR = Cells(Rows.Count, 9).End(xlUp).Row For R = 11 To RR For TT = 1 To 12 AC = Choose(TT, 9, 14, 20, 25, 31, 36, 70, 75, 109, 114, 120, 125) AT = Choose(TT, 10, 15, 21, 26, 32, 37, 71, 76, 110, 115, 121, 126) AD = Choose(TT, 11, 16, 22, 27, 33, 38, 72, 77, 111, 116, 122, 127) If Cells(R, AC) = "غ" And Cells(R, AT) = "غ" Then Cells(R, AD) = "غ" Else Cells(R, AD) = Val(Cells(R, AC)) + Val(Cells(R, AT)) If Cells(R, AC) = "" And Cells(R, AT) = "" Then Cells(R, AD) = "" End If Next Next .ScreenUpdating = True .EnableEvents = True End With End Sub

السلام عليكم تفضل A_فاتورة (Autosaved) 3.rar

اعطيني مثال أين من الموردين يعتبر رصيده صفري جرب المرفق وهل المفلتر هم الموردين المطلوب حذفهم Suppliers2012_A.rar

ارفق مثال وبه شرح ماتريد

السلام عليكم تفضل Sub Ali_Dle() Dim L_R&, I% Dim II As Variant With Application .ScreenUpdating = False .EnableEvents = False With Sheet1 .Unprotect L_R = .Cells(Rows.Count, 3).End(xlUp).Row For II = L_R To 6 Step -1 If .Range("L" & II).Value = 0 Then .Rows(II).DELETE: I = I + 1 Next II MsgBox " ثم حـذف " & I & " : سطـر حسب الشـرط ", vbInformation End With .ScreenUpdating = True .EnableEvents = True End With End Sub

السلام عليكم هذه طريقة تحايل بسيطه لاسترجاع بعد تنفيذ الكود لاكن فيها بطئ فرضاً هذا الكود المستخدم Sub XXXXXX_A() '*************** ' تحط هذا بداية الكود لحفظ النطاق قيل التنفيذ Sav_Ali '*************** [A2:A10].Clear End Sub وهذا كود حقظ بيانات النطاق Type S_Ali V_A As Variant D_A As String End Type Public ACT_BOOK As Workbook Public ACT_SH As Worksheet Public ACT_R() As S_Ali Sub Sav_Ali() Application.ScreenUpdating = False Dim R As Range Set R = [A1:Z500] If TypeName(R) <> "Range" Then Exit Sub ReDim ACT_R(R.Count) Set ACT_BOOK = ActiveWorkbook Set ACT_SH = ActiveSheet I = 0 For Each CE In R I = I + 1 ACT_R(I).D_A = CE.Address ACT_R(I).V_A = CE.Formula Next CE Application.ScreenUpdating = True End Sub وهذا الكود للاسترجاع ماقبل تنفيذ الكود Sub UO_Ali() With Application .ScreenUpdating = False .EnableEvents = False On Error GoTo Err Application.ScreenUpdating = False ACT_BOOK.Activate ACT_SH.Activate For I = 1 To UBound(ACT_R) Range(ACT_R(I).D_A).Formula = ACT_R(I).V_A Next I .ScreenUpdating = True .EnableEvents = True End With Exit Sub Err: MsgBox "حدث خطاء لايمكن الإسترجاع" End Sub ربما تفيد البعض هذه الطريقة

السلام عليكم نفس المعادلات فقط اضافة التنسيق حسب فهمي للمطلوب [C1] =IF(A1=0,0,TEXT(MID(A1,FIND(I1,A1),LEN(I1)),"0.00000")) [C2] =IF(A2=0,0,TEXT(MID(A2,FIND(I2,A2),LEN(I2)),"0.00000"))

السلام عليكم تفضل A_فاتورة (Autosaved).rar

وعليكم السلام سلمت استاذ عبدالله على المرور العطر وجزاك الله خير على اعمالك المتقنه تلميذك أبو نصار

السلام عليكم الاخوة الاحبه سعد عابد وأبو ردينه جزاكم الله خير على الكلمات الطيبه والمرور العطر الفضل يعود للأستاذ الحبيب خبور خير

السلام عليكم تفضل 510_A.rar

السلام عليكم جرب المرفق هذا مقتبس من أعمال الاستاذ الكبير عبدالله باقشير حفظه الله User_Ali.rar User_Ali_1.rar

قم بتحميل المرفق مره اخرى

جرب المرفق بنفس المشاركه السابقة بمجرد الكتابه يظهر البيانات