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

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

السلام عليكم اخي ابو انس في الملف معاينة الي في المشاركة 7 شغل الفورم ثم احفظ الصور التي تريدها ستجدها في فولدر ملف الاكسل بعدين افتح ملفك من محرر الاكواد في الفورم حمل الصور على الليبلات يعني اثناء التصميم جرب واخبرني بالنتيجة تقبل تحياتي وشكري

اخي ابو انصار -----------حفظك ربي مرورك يسعدني اكرمك الله واثابك بدعائك واعطاك بمثله اضعاف مضاعفة و جزاك خيرا وبارك فيك تقبل تحياتي وشكري

السلام عليكم هذا الكود مجرب على قاعدة بيانات فيها اكثر من 15000 سجل Option Explicit Private Const ContColmn As Integer = 5 '====================================================== '====================================================== Sub kh_mReport() Dim xx Dim x(), AryList() Dim Rng As Range Dim i As Long, LastRow As Long, iCont As Long Dim c As Integer, m As Integer Dim Md As Double, Dn As Double Dim v1 As Double, v2 As Double Dim S As String ''''''''''''''''''''' Dim Co As New Collection '============================================ With Cells.Worksheet LastRow = .Cells(Rows.Count, "A").End(xlUp).Row With .Range("A2") .Activate .Resize(1, ContColmn).ClearContents .Offset(1, 0).Resize(LastRow, ContColmn).Clear End With End With '============================================ With Sheets("dailyd1ary") LastRow = .Cells(Rows.Count, "C").End(xlUp).Row Set Rng = .Range("C2:G" & LastRow) End With '============================================ On Error GoTo kh_ex kh_Application False ''''''''''''''''''''' ReDim x(0 To 2) With Rng For i = 1 To .Rows.Count v1 = 0: v2 = 0 1: On Error Resume Next '''''''''''''''''' Md = Val(.Cells(i, 2)) Dn = Val(.Cells(i, 3)) S = CStr(.Cells(i, 4)) '''''''''''''''''' x(0) = Val(S) x(1) = Md + v1 x(2) = Dn + v2 ''''''''''''''''''' Co.Add x, S ''''''''''''''''''' If Err Then v1 = Val(Co(S)(1)): v2 = Val(Co(S)(2)) Co.Remove S Err.Clear GoTo 1 End If ''''''''''''''''''' Next End With '============================================ iCont = Co.Count If iCont Then Set Rng = Sheets("accounts").Range("A2:A1000") ReDim AryList(1 To iCont, 1 To ContColmn) For i = 1 To iCont xx = Co.Item(i) On Error Resume Next m = WorksheetFunction.Match(xx(0), Rng, 0) If Err Then m = 0: Err.Clear AryList(i, 1) = xx(0) If m Then AryList(i, 2) = Rng.Cells(m, 2) AryList(i, 3) = xx(1) AryList(i, 4) = xx(2) AryList(i, 5) = Val(xx(1)) - Val(xx(2)) Next ''''''''''''''''''''''''' With Range("A2").Resize(iCont, ContColmn) If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats .Value = AryList .Sort .Columns(1), xlAscending End With ''''''''''''''''''''''''' End If '============================================ kh_ex: kh_Application True '''''''''''''''''' If Err Then MsgBox "Err.Number : " & Err.Number Err.Clear Else MsgBox "تم تحديث الميزان بنجاح ", vbMsgBoxRight, "الحمدلله" End If Set Co = Nothing Set Rng = Nothing Erase AryList, x End Sub Sub kh_Application(mbol As Boolean) With Application .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol .EnableEvents = mbol End With End Sub المرفق 2003-2007 ميزان مراجعة.rar

اخي عياس حفظك ربي اثابك الله بدعائك واعطاك بمثله اضعاف مضاعفة و جزاك خيرا وبارك فيك تقبل تحياتي وشكري

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

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

اخي انس دروبي حفظك ربي انا رايت ملفك بالامس وقررت تنفيذ هذا العمل على ضوء مشاهدتي للملف وخاصة ان الفكرة توصلت اليها قريبا مع اخي الخالدي في موضوع اضافة اسماء للشيتات من خلايا في قائمة بالنسبة لسؤالك عن رقم الصور في المرفق فورم يمكنك من البحث و مشاهدة الصورة وحفظها بعدة صيغ ان اردت المرفق 2003 معاينة وحفظ صور قوائم الاكسل2.rar

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

السلام عليكم قوائم مخصصة على الفورم باستخدام CommandBars المرفق 2003-2007 قوائم مخصصة على الفورم باستخدام كومندبار.rar هذا الموضوع الاحدث http://www.officena.net/ib/index.php?showtopic=47195

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

السلام عليكم السبب وجود اوامر في الكود تقوم بذلك تفضل المرفق 2003 بع تعطيل اسطر الاوامر مع تعديل طفيف اضغط انتر لان كلمة المرور موجودة على التاكست وهي الرقم 1 قم بمسح التاكست اثناء التصميم بعد الفتح تعديل على الفورم.rar

السلام عليكم احسنت اخي الحبيب احمد حفظك الله تفبل تحياتي وشكري

لا يمكنني تطبيق الكود باتقان بوجود اكواد اخرى للدخول والخروج وخاصة كود اخفاء الاكسل في امان الله

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

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

السلام عليكم اثراءا للموضوع مع الشكر لاخي عباد بمثل هذا الكود اطلع ميزان مراجعة لاكثر من 15000 سجل Option Explicit ' عدد الاعمدة في الكشف Const ContColmn As Integer = 6 ' عمود الاسم من نطاق البيانات Const iName As Integer = 5 ' عمود التاريخ من نطاق البيانات Const idate As Integer = 4 ' عمود المجموع من نطاق البيانات Const iSm As Integer = 9 '====================================================== '====================================================== Sub kh_Report() Dim Co As New Collection Dim x() Dim v As Double Dim iTm As Range, Rng As Range Dim i As Long, LastRow As Long, iCont As Long Dim c As Integer ''''''''''''''''''''' LastRow = Cells(Rows.Count, "B").End(xlUp).Row Range("B6").Resize(LastRow, ContColmn).ClearContents ''''''''''''''''''''' With Sheets("مشتريات") LastRow = .Cells(Rows.Count, "B").End(xlUp).Row Set Rng = .Range("B5:B" & LastRow) End With ''''''''''''''''''''' ReDim x(1 To ContColmn) ''''''''''''''''''''' On Error GoTo kh_ex ''''''''''''''''''''' For Each iTm In Rng If kh_Tst(iTm.Cells(1, iName), iTm.Cells(1, idate)) Then v = 0 1: On Error Resume Next For c = 1 To 5 x(c) = iTm.Cells(1, c) Next x(6) = Val(iTm.Cells(1, iSm)) + v ''''''''''''''''''' Co.Add x, CStr(iTm) ''''''''''''''''''' If Err Then v = Val(Co(CStr(iTm))(6)) Co.Remove CStr(iTm) Err.Clear GoTo 1 End If ''''''''''''''''''' End If Next ''''''''''''''''''''''''' iCont = Co.Count If iCont Then For i = 1 To iCont With Range("B6") .Cells(i, 1).Resize(1, ContColmn).Value = Co.Item(i) End With Next End If ''''''''''''''''''''''''' With Range("B6").Resize(iCont, ContColmn) .Sort .Columns(1), xlAscending End With ''''''''''''''''''''''''' kh_ex: '''''''''''''''''' Set Co = Nothing Set Rng = Nothing Erase x End Sub Function kh_Tst(N As String, dd) As Boolean Dim ib As Boolean If N = Trim(Range("E2").Value) Then Select Case dd Case Range("E3").Value2 To Range("E4").Value2 ib = True End Select End If kh_Tst = ib End Function المرفق 2003 كشف حساب اجمالي سعد.rar

السلام عليكم جرب هذه الخطوات قبل النسخ حول اللغة الى عربي ثم قم بالنسخ

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

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

إسم الملف: اداة لتصوير وحفظ صورة من الشاشة مع اضافة شرح أضيف للمكتبة بواسطة: عبدالله باقشير تاريخ الإضافة: 06 Dec 2012 القسم فى المكتبة: أدوات عامة السلام عليكم اداة لتصوير وحفظ صورة من الشاشة مع اضافة شرح في مربع النص الظاهر معاك في الشاشة الاستخدام: شرح مدعوم بالصور معمولة بالفيجول بيسك متطلبات النظام: ويندوز اكس بي إضغط هنـــــــــــا لتنزيل الملف

السلام عليكم هذه معادلة مجموع الاجازات المرضية ضعها في الخلية d2 واسحبها على بقية العمود =SUM(OFFSET(Sheet1!$D$1;MATCH(C2;Sheet1!C:C;0)-1;0;1;12)) هذه معادلة مجموع الغياب ضعها في الخلية p2 واسحبها على بقية العمود =SUM(OFFSET(Sheet1!$P$1;MATCH(C2;Sheet1!C:C;0)-1;0;1;12)) في امان الله

السلام عليكم دالة إزالة كافة المسافات من النص ماعدا المسافات المفردة بين الكلمات. Option Explicit Function kh_Trim(MyText As String) As String Dim tx, tex$ For Each tx In Split(MyText) If Len(tx) Then tex = tex & " " & tx Next kh_Trim = Trim(tex) End Function

هذا الموضوع كان لمناقشة بعض المسائل في منتدى الاكسس ساعمل موضوع آخر مع شرح الية عمل الملف ان شاء الله قريبا

السلام عليكم .Offset(1, 1) = TextBox2.Value