الـعيدروس

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

السلام عليكم الاخ الحبيب A L M A I S T R O عدلت على ملف الاستاذ العلامه خبور وهذا بعد اذنه بما يتماشا مع طلبك الاليه كالتالي : أولا تحدد نوع الإمتداد ثم تضغط زر "إختار المجلد الرئيسي" بدوره يخرج مسار ملفات الاكسل من المجلدات الفرعيه للمجلد المحدد أو حتى قرص محدد ثم تحدد نوع الإمتداد مثلاً xls او xlsm او الخ ...... ورقة البحث الافتراضيه للملفات هيا الاولى و المدى الافتراضي = "A1:Z1000" واشياء اخرى اكتشفها في الملف ارجو التجربه ان وجدت اخطاء او ملاحظات انا موجود ---------------------------------- للمعلومية ...... حاول الا تبحث بقرص كامل لانه حتماً سيكون بطيئ جداً احبذ اختيار مجلد معين ---------------------------------- المرفق الاول شرح الية العمل المرفق الاخر الملف شرح_بحث.rar Kh_Srech.rar

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

توضيح مصدر قائمة "يصرف المبلغ الموضح اعلاه " مصدرها الاسم "موظف" في قائمة الاسماء عمود "AH"

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

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

السلام عليكم ====================== استثمرنا درر للاستاذ عبدالله باقشير ====================== وهو فورم من احد اعماله لعمل سند امر صرف وبالامكان تطويعه لاشياء اخر اترككم مع الملف المرفق الاول شرح العمل عليه والاخر البرنامج واذا هناك ملاحظات او اخطاء ارجو طرحها لاني عملت عليه على عجله من امري دعواتكم لصاحب الاعمال الخالدة ( عبدالله باقشير حفظه الله ) ولاخوكم المجتهد أبو نصار ( عباد ) تحياتي شرح.rar أمر صرف.rar

جزيتى خيرا ياام عبدالله كود قيم زيادة في المعلومية لمن لايعرف فيه دالة في الاكسل تعمل في اوفيس 2010 فقط عمله تقوم بحساب ايام العمل بين تاريخين مع تحديد ايام العمل بدون العطل والاجازات =NETWORKDAYS.INTL(start_date, end_date [,weekend] [,holidays]) * start_date من تاريخ = تاريخ بداية العمل * end_date الى تاريخ = تاريخ النهاية ( على ان لايتجاوز التاريخ الحالي او الدالة بتظهر خطاء ؟ ) * [weekend] اول يوم عمل في الاسبوع = تحط رقم اليوم بدون العطل والاجازة 1 السبت *[ holidays] اخر يوم عمل في الاسبوع = تحط رقم اليوم مثلاً 6 الخميس على ان الجمعه عطله اذا ( الخميس والجمعه عطله تحدد 1 و 5

نعم ممكن الباركود يعمل مع الاكسل

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

اطلع على المرفق يومية مبيعات_Ali4.rar

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

السلام عليكم جرب الكود التالي Public Sub Ali_Rebt() Dim Nm As Variant Dim Nm_Cl As New Collection Dim Tr_Nm As Variant Nm = Range(Cells(1, 2), Cells(2, 11)).Value On Error Resume Next For Each Tr_Nm In Nm Nm_Cl.Add Tr_Nm, Tr_Nm Next Tr_Nm On Error GoTo 0 For Tr_Nm = 1 To Nm_Cl.Count Cells(4, Tr_Nm) = Nm_Cl(Tr_Nm) Next Tr_Nm End Sub

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

ان عطل الماكرو لن يستطيع تغيير كلمة مرور الـ sheet لان كلمة مرور الـ sheet ليست لها صله بتفعيل او تعطيل الماكرو

ماالمطلوب ؟ كيف يعني إسترجاع كلمة مرور ؟ لم افهم ماتريد هل تريد من الكود يرجع الباسورد السابق ؟

السلام عليكم جرب المرفق ولا عليك معك إلى أن نكمل إن شاء الله يومية مبيعات_Ali2.rar

السلام عليكم واجهة المتابعة "التقرير" جرب المرفق فيه خلايا في ورقة التقرير مثل الوزن الحالي متى يسجل الوزن للمريض عند المتابعه او التسجيل الجديد ؟ برنامج_Ali1.rar

تفضل Public Function Sum_Ali(rng As Range, الشرط$) As Double Dim Rr As Range Dim Irn As Range Application.Volatile '************** s$ = الشرط '"200 مم" '************** For Each Irn In rng If Irn = s Then If Not Rr Is Nothing Then Set Rr = Union(Rr, Irn.Offset(0, 1)) Else Set Rr = Irn.Offset(0, 1) End If End If Next Sum_Ali = Application.Subtotal(9, Rr) End Function

ارفق مثال اذا تكرمت وبه معطيات والنتائج المراده كمثال

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

او هكذا Public Function Sum_Ali(rng As Range, الشرط$) As Double Dim Rr As Range Dim Irn As Range Application.Volatile '************** s$ = الشرط '"200 مم" '************** For Each Irn In rng If Irn = s And Not Irn.Rows.Hidden Then If Not Rr Is Nothing Then Set Rr = Union(Rr, Irn.Offset(0, 1)) Else Set Rr = Irn.Offset(0, 1) End If End If Next Sum_Ali = Application.Sum(Rr) End Function

السلام عليكم إستخدام المعادلة المركبة كالتالي =Sum_Ali(G3:G26;"200 مم") Public Function Sum_Ali(rng As Range, الشرط$) As Double Dim Irn As Range Dim Cn# Application.Volatile '************** S$ = الشرط '"200 مم" '************** For Each Irn In rng If Irn = S Then If Irn.Rows.Hidden = 0 Then Cn = Cn + Val(Irn.Offset(0, 1)) End If End If Next Sum_Ali = Cn End Function

اذا الكود نتائجة سليمة ضيف السطر التالي اول الكود on error resume next

اتمنى ان اكون فهمت طلبك بالشكل الصحيح جرب هذا التعديل حسب شروطك طال الكود حبتين Private Const Nm As String = "مصروفات السيارات" Public N_Sh$ Public Sub Ali_Tr() Dim Sh As Worksheet Dim S As Worksheet Dim My_r As Range Dim Lr& Dim My_mx() As Variant Dim Ar_mx() As Variant Dim Ar As Variant Dim cn&, rwn& Dim Z, Nr Set S = Sheets(Nm) S.Cells.Clear For Each Sh In ThisWorkbook.Worksheets With Sh Select Case .Name Case Is = Nm, "كشف حساب", "تقارير" Case Else N_Sh = .Name Set Rn = .Range("B21:F26") With Rn For Z = 1 To .Rows.Count cn = 3 rwn = .Rows.Count ReDim Preserve My_mx(1 To rwn, 1 To cn) If .Cells(Z, 4).Value > 0 Then If i = rwn Then GoTo 1 i = i + 1 Ar = Array(Sh.[B14] & " " & Application.Text(Sh.[C14], "[$-C01]dddd"), _ Sh.[G14] & " " & Application.Text(Sh.[H14], "yyyy/mm/dd")) My_mx(i, 1) = CStr(.Cells(Z, 1)): My_mx(i, 2) = CStr(.Cells(Z, 4)) My_mx(i, 3) = CStr(.Cells(Z, 5)) End If 1 Next End With '================================================== Set Rng = .Range("B32:D36") With Rng For Nr = 1 To .Rows.Count cl = 3 rw = .Rows.Count ReDim Preserve Ar_mx(1 To rw, 1 To cl) If .Cells(Nr, 2).Value > 0 Then If ii = rw Then GoTo 0 ii = ii + 1 Ar_mx(ii, 1) = CStr(.Cells(Nr, 1)): Ar_mx(ii, 2) = CStr(.Cells(Nr, 2)) Ar_mx(ii, 3) = CStr(.Cells(Nr, 3)) End If 0 Next End With With S Lr = Cells(.Rows.Count, 2).End(xlUp).Offset(2, 0).Row .Cells(Lr, 1).Resize(, 2) = Array(N_Sh, "مصروفات سيارة") .Range(.Cells(Lr + 1, 2).Address).Resize(, UBound(Ar) + 1) = Ar .Range(.Cells(Lr + 2, 2).Address).Resize(, 3) = Array("إسم المندوب", "مبلغ", "ملاحظات") .Range(.Cells(Lr + 3, 2).Address).Resize(UBound(My_mx, 1), UBound(My_mx, 2)) = My_mx Lrr = Cells(.Rows.Count, 2).End(xlUp).Offset(2, 0).Row .Cells(Lrr, 3) = "المصروفات الاخرى للسيارات" .Range(.Cells(Lrr + 1, 2).Address).Resize(, 3) = Array("الإسم", "قيمة المصروف", "ملاحظات") With .Range(.Cells(Lrr + 2, 2).Address) .Resize(UBound(Ar_mx, 1), UBound(Ar_mx, 2)) = Ar_mx Lrw = S.Cells(Rows.Count, 2).End(xlUp).Row With S.Range(S.Cells(Lrw, 1).Address).Resize(, 10) .Borders(xlDiagonalDown).LineStyle = xlNone: .Borders(xlDiagonalUp).LineStyle = xlNone .Borders(xlEdgeLeft).LineStyle = xlNone: .Borders(xlEdgeTop).LineStyle = xlNone With .Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 0: .Color = RGB(255, 0, 0) .TintAndShade = 0: .Weight = xlThin End With End With End With End With Erase My_mx: i = 0: Erase Ar_mx: ii = 0 End Select End With Next End Sub